library(dplyr)
library(kableExtra)
library(ggplot2)
library(knitr)
library(corrplot)
library(FactoMineR)
library(ggdendro)
library(GGally)
library(caret)
library(splines)
library(tidyr)
options(knitr.table.format = "html")
#Funciones para los graficos
give.n <- function(x,n){
return(c(y = mean(x)*1.5, label = length(x)))
}
give1.n<-function(x,n){
return(c(y = mean(x)*1.5, label = length(x)))
}
my_rg1 <- function(data, mapping, ...){
p <- ggplot(data = data, mapping = mapping) +
geom_point() +
geom_smooth(method='loess', fill="red", color="red",se=FALSE) +
geom_smooth(method='lm', fill="cyan", color="cyan",se=FALSE)
p
}
my_rg2 <- function(data, mapping, ...){
p <- ggplot(data = data,mapping=mapping) +
geom_point() +
geom_smooth(method='lm',formula=y~splines::bs(x),fill='darkorchid3',color='darkorchid3',se=FALSE) +
geom_smooth(method='lm',formula=y~poly(x),fill='orangered',color='orangered',se=FALSE)
p
}
my_rg3 <- function(data, mapping, ...){
p <- ggplot(data = data, mapping = mapping) +
geom_point() +
geom_smooth(method='lm',formula=y~splines::bs(x),fill='darkgreen',color='darkgreen',alpha=.1) +
geom_smooth(method='loess', fill="firebrick1", color="firebrick1",alpha=.1)
p
}
#Solo para las discretas
my_rg4 <- function(data, mapping, ...){
p <- ggplot(data = data, mapping = mapping) +
geom_point() +
geom_smooth(method='lm',fill='purple',color='purple',alpha=.3)
p
}
#Funcion para regresion
normalize <- function(x) {
return ((x - min(x)) / (max(x) - min(x))) }
Tenemos un archivo de entrenamiento para realizar un aprendizaje supervisado formado por 1460 casos con 81 variables.
Una de ellas es nuestro objetivo SalePrice, y debemos ser capaces de predecir esa variable con el dataframe Test que se nos proporciona, que es de 1459 casos.
Otra variable importante es la primera, Id que nos identifica de manera única cada registro.
En el dataframe Train tenemos los 1460 primeros.
En el dataframe Test tenemos desde el 1461 hasta el 2919
Tenemos varios tipos de variables, como se vera en el siguiente epígrafe, además de las cuales cambiaremos los tipos de algunas.
Hay que realizar una limpieza y control exhaustiva de todos los datos, haciendo énfasis en los valores NA
Para realizar una preparación adecuada y buscar un modelo hay que unir los dos dataframe creando los datos que nos faltan en Test (SalePrice la variable objetivo ) y poniendo como valor NA
url_test="https://www.kaggle.com/c/house-prices-advanced-regression-techniques/download/test.csv"
url_train="https://www.kaggle.com/c/house-prices-advanced-regression-techniques/download/train.csv"
train<-read.csv("train.csv",sep = ",", header=TRUE,stringsAsFactors = FALSE)
test<-read.csv("test.csv",sep=",",header=TRUE,stringsAsFactors = FALSE)summary(train)
## Id MSSubClass MSZoning LotFrontage
## Min. : 1.0 Min. : 20.0 Length:1460 Min. : 21.00
## 1st Qu.: 365.8 1st Qu.: 20.0 Class :character 1st Qu.: 59.00
## Median : 730.5 Median : 50.0 Mode :character Median : 69.00
## Mean : 730.5 Mean : 56.9 Mean : 70.05
## 3rd Qu.:1095.2 3rd Qu.: 70.0 3rd Qu.: 80.00
## Max. :1460.0 Max. :190.0 Max. :313.00
## NA's :259
## LotArea Street Alley LotShape
## Min. : 1300 Length:1460 Length:1460 Length:1460
## 1st Qu.: 7554 Class :character Class :character Class :character
## Median : 9478 Mode :character Mode :character Mode :character
## Mean : 10517
## 3rd Qu.: 11602
## Max. :215245
##
## LandContour Utilities LotConfig
## Length:1460 Length:1460 Length:1460
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
##
## LandSlope Neighborhood Condition1
## Length:1460 Length:1460 Length:1460
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
##
## Condition2 BldgType HouseStyle OverallQual
## Length:1460 Length:1460 Length:1460 Min. : 1.000
## Class :character Class :character Class :character 1st Qu.: 5.000
## Mode :character Mode :character Mode :character Median : 6.000
## Mean : 6.099
## 3rd Qu.: 7.000
## Max. :10.000
##
## OverallCond YearBuilt YearRemodAdd RoofStyle
## Min. :1.000 Min. :1872 Min. :1950 Length:1460
## 1st Qu.:5.000 1st Qu.:1954 1st Qu.:1967 Class :character
## Median :5.000 Median :1973 Median :1994 Mode :character
## Mean :5.575 Mean :1971 Mean :1985
## 3rd Qu.:6.000 3rd Qu.:2000 3rd Qu.:2004
## Max. :9.000 Max. :2010 Max. :2010
##
## RoofMatl Exterior1st Exterior2nd
## Length:1460 Length:1460 Length:1460
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
##
## MasVnrType MasVnrArea ExterQual ExterCond
## Length:1460 Min. : 0.0 Length:1460 Length:1460
## Class :character 1st Qu.: 0.0 Class :character Class :character
## Mode :character Median : 0.0 Mode :character Mode :character
## Mean : 103.7
## 3rd Qu.: 166.0
## Max. :1600.0
## NA's :8
## Foundation BsmtQual BsmtCond
## Length:1460 Length:1460 Length:1460
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
##
## BsmtExposure BsmtFinType1 BsmtFinSF1 BsmtFinType2
## Length:1460 Length:1460 Min. : 0.0 Length:1460
## Class :character Class :character 1st Qu.: 0.0 Class :character
## Mode :character Mode :character Median : 383.5 Mode :character
## Mean : 443.6
## 3rd Qu.: 712.2
## Max. :5644.0
##
## BsmtFinSF2 BsmtUnfSF TotalBsmtSF Heating
## Min. : 0.00 Min. : 0.0 Min. : 0.0 Length:1460
## 1st Qu.: 0.00 1st Qu.: 223.0 1st Qu.: 795.8 Class :character
## Median : 0.00 Median : 477.5 Median : 991.5 Mode :character
## Mean : 46.55 Mean : 567.2 Mean :1057.4
## 3rd Qu.: 0.00 3rd Qu.: 808.0 3rd Qu.:1298.2
## Max. :1474.00 Max. :2336.0 Max. :6110.0
##
## HeatingQC CentralAir Electrical X1stFlrSF
## Length:1460 Length:1460 Length:1460 Min. : 334
## Class :character Class :character Class :character 1st Qu.: 882
## Mode :character Mode :character Mode :character Median :1087
## Mean :1163
## 3rd Qu.:1391
## Max. :4692
##
## X2ndFlrSF LowQualFinSF GrLivArea BsmtFullBath
## Min. : 0 Min. : 0.000 Min. : 334 Min. :0.0000
## 1st Qu.: 0 1st Qu.: 0.000 1st Qu.:1130 1st Qu.:0.0000
## Median : 0 Median : 0.000 Median :1464 Median :0.0000
## Mean : 347 Mean : 5.845 Mean :1515 Mean :0.4253
## 3rd Qu.: 728 3rd Qu.: 0.000 3rd Qu.:1777 3rd Qu.:1.0000
## Max. :2065 Max. :572.000 Max. :5642 Max. :3.0000
##
## BsmtHalfBath FullBath HalfBath BedroomAbvGr
## Min. :0.00000 Min. :0.000 Min. :0.0000 Min. :0.000
## 1st Qu.:0.00000 1st Qu.:1.000 1st Qu.:0.0000 1st Qu.:2.000
## Median :0.00000 Median :2.000 Median :0.0000 Median :3.000
## Mean :0.05753 Mean :1.565 Mean :0.3829 Mean :2.866
## 3rd Qu.:0.00000 3rd Qu.:2.000 3rd Qu.:1.0000 3rd Qu.:3.000
## Max. :2.00000 Max. :3.000 Max. :2.0000 Max. :8.000
##
## KitchenAbvGr KitchenQual TotRmsAbvGrd Functional
## Min. :0.000 Length:1460 Min. : 2.000 Length:1460
## 1st Qu.:1.000 Class :character 1st Qu.: 5.000 Class :character
## Median :1.000 Mode :character Median : 6.000 Mode :character
## Mean :1.047 Mean : 6.518
## 3rd Qu.:1.000 3rd Qu.: 7.000
## Max. :3.000 Max. :14.000
##
## Fireplaces FireplaceQu GarageType GarageYrBlt
## Min. :0.000 Length:1460 Length:1460 Min. :1900
## 1st Qu.:0.000 Class :character Class :character 1st Qu.:1961
## Median :1.000 Mode :character Mode :character Median :1980
## Mean :0.613 Mean :1979
## 3rd Qu.:1.000 3rd Qu.:2002
## Max. :3.000 Max. :2010
## NA's :81
## GarageFinish GarageCars GarageArea GarageQual
## Length:1460 Min. :0.000 Min. : 0.0 Length:1460
## Class :character 1st Qu.:1.000 1st Qu.: 334.5 Class :character
## Mode :character Median :2.000 Median : 480.0 Mode :character
## Mean :1.767 Mean : 473.0
## 3rd Qu.:2.000 3rd Qu.: 576.0
## Max. :4.000 Max. :1418.0
##
## GarageCond PavedDrive WoodDeckSF OpenPorchSF
## Length:1460 Length:1460 Min. : 0.00 Min. : 0.00
## Class :character Class :character 1st Qu.: 0.00 1st Qu.: 0.00
## Mode :character Mode :character Median : 0.00 Median : 25.00
## Mean : 94.24 Mean : 46.66
## 3rd Qu.:168.00 3rd Qu.: 68.00
## Max. :857.00 Max. :547.00
##
## EnclosedPorch X3SsnPorch ScreenPorch PoolArea
## Min. : 0.00 Min. : 0.00 Min. : 0.00 Min. : 0.000
## 1st Qu.: 0.00 1st Qu.: 0.00 1st Qu.: 0.00 1st Qu.: 0.000
## Median : 0.00 Median : 0.00 Median : 0.00 Median : 0.000
## Mean : 21.95 Mean : 3.41 Mean : 15.06 Mean : 2.759
## 3rd Qu.: 0.00 3rd Qu.: 0.00 3rd Qu.: 0.00 3rd Qu.: 0.000
## Max. :552.00 Max. :508.00 Max. :480.00 Max. :738.000
##
## PoolQC Fence MiscFeature
## Length:1460 Length:1460 Length:1460
## Class :character Class :character Class :character
## Mode :character Mode :character Mode :character
##
##
##
##
## MiscVal MoSold YrSold SaleType
## Min. : 0.00 Min. : 1.000 Min. :2006 Length:1460
## 1st Qu.: 0.00 1st Qu.: 5.000 1st Qu.:2007 Class :character
## Median : 0.00 Median : 6.000 Median :2008 Mode :character
## Mean : 43.49 Mean : 6.322 Mean :2008
## 3rd Qu.: 0.00 3rd Qu.: 8.000 3rd Qu.:2009
## Max. :15500.00 Max. :12.000 Max. :2010
##
## SaleCondition SalePrice
## Length:1460 Min. : 34900
## Class :character 1st Qu.:129975
## Mode :character Median :163000
## Mean :180921
## 3rd Qu.:214000
## Max. :755000
## str(train)
## 'data.frame': 1460 obs. of 81 variables:
## $ Id : int 1 2 3 4 5 6 7 8 9 10 ...
## $ MSSubClass : int 60 20 60 70 60 50 20 60 50 190 ...
## $ MSZoning : chr "RL" "RL" "RL" "RL" ...
## $ LotFrontage : int 65 80 68 60 84 85 75 NA 51 50 ...
## $ LotArea : int 8450 9600 11250 9550 14260 14115 10084 10382 6120 7420 ...
## $ Street : chr "Pave" "Pave" "Pave" "Pave" ...
## $ Alley : chr NA NA NA NA ...
## $ LotShape : chr "Reg" "Reg" "IR1" "IR1" ...
## $ LandContour : chr "Lvl" "Lvl" "Lvl" "Lvl" ...
## $ Utilities : chr "AllPub" "AllPub" "AllPub" "AllPub" ...
## $ LotConfig : chr "Inside" "FR2" "Inside" "Corner" ...
## $ LandSlope : chr "Gtl" "Gtl" "Gtl" "Gtl" ...
## $ Neighborhood : chr "CollgCr" "Veenker" "CollgCr" "Crawfor" ...
## $ Condition1 : chr "Norm" "Feedr" "Norm" "Norm" ...
## $ Condition2 : chr "Norm" "Norm" "Norm" "Norm" ...
## $ BldgType : chr "1Fam" "1Fam" "1Fam" "1Fam" ...
## $ HouseStyle : chr "2Story" "1Story" "2Story" "2Story" ...
## $ OverallQual : int 7 6 7 7 8 5 8 7 7 5 ...
## $ OverallCond : int 5 8 5 5 5 5 5 6 5 6 ...
## $ YearBuilt : int 2003 1976 2001 1915 2000 1993 2004 1973 1931 1939 ...
## $ YearRemodAdd : int 2003 1976 2002 1970 2000 1995 2005 1973 1950 1950 ...
## $ RoofStyle : chr "Gable" "Gable" "Gable" "Gable" ...
## $ RoofMatl : chr "CompShg" "CompShg" "CompShg" "CompShg" ...
## $ Exterior1st : chr "VinylSd" "MetalSd" "VinylSd" "Wd Sdng" ...
## $ Exterior2nd : chr "VinylSd" "MetalSd" "VinylSd" "Wd Shng" ...
## $ MasVnrType : chr "BrkFace" "None" "BrkFace" "None" ...
## $ MasVnrArea : int 196 0 162 0 350 0 186 240 0 0 ...
## $ ExterQual : chr "Gd" "TA" "Gd" "TA" ...
## $ ExterCond : chr "TA" "TA" "TA" "TA" ...
## $ Foundation : chr "PConc" "CBlock" "PConc" "BrkTil" ...
## $ BsmtQual : chr "Gd" "Gd" "Gd" "TA" ...
## $ BsmtCond : chr "TA" "TA" "TA" "Gd" ...
## $ BsmtExposure : chr "No" "Gd" "Mn" "No" ...
## $ BsmtFinType1 : chr "GLQ" "ALQ" "GLQ" "ALQ" ...
## $ BsmtFinSF1 : int 706 978 486 216 655 732 1369 859 0 851 ...
## $ BsmtFinType2 : chr "Unf" "Unf" "Unf" "Unf" ...
## $ BsmtFinSF2 : int 0 0 0 0 0 0 0 32 0 0 ...
## $ BsmtUnfSF : int 150 284 434 540 490 64 317 216 952 140 ...
## $ TotalBsmtSF : int 856 1262 920 756 1145 796 1686 1107 952 991 ...
## $ Heating : chr "GasA" "GasA" "GasA" "GasA" ...
## $ HeatingQC : chr "Ex" "Ex" "Ex" "Gd" ...
## $ CentralAir : chr "Y" "Y" "Y" "Y" ...
## $ Electrical : chr "SBrkr" "SBrkr" "SBrkr" "SBrkr" ...
## $ X1stFlrSF : int 856 1262 920 961 1145 796 1694 1107 1022 1077 ...
## $ X2ndFlrSF : int 854 0 866 756 1053 566 0 983 752 0 ...
## $ LowQualFinSF : int 0 0 0 0 0 0 0 0 0 0 ...
## $ GrLivArea : int 1710 1262 1786 1717 2198 1362 1694 2090 1774 1077 ...
## $ BsmtFullBath : int 1 0 1 1 1 1 1 1 0 1 ...
## $ BsmtHalfBath : int 0 1 0 0 0 0 0 0 0 0 ...
## $ FullBath : int 2 2 2 1 2 1 2 2 2 1 ...
## $ HalfBath : int 1 0 1 0 1 1 0 1 0 0 ...
## $ BedroomAbvGr : int 3 3 3 3 4 1 3 3 2 2 ...
## $ KitchenAbvGr : int 1 1 1 1 1 1 1 1 2 2 ...
## $ KitchenQual : chr "Gd" "TA" "Gd" "Gd" ...
## $ TotRmsAbvGrd : int 8 6 6 7 9 5 7 7 8 5 ...
## $ Functional : chr "Typ" "Typ" "Typ" "Typ" ...
## $ Fireplaces : int 0 1 1 1 1 0 1 2 2 2 ...
## $ FireplaceQu : chr NA "TA" "TA" "Gd" ...
## $ GarageType : chr "Attchd" "Attchd" "Attchd" "Detchd" ...
## $ GarageYrBlt : int 2003 1976 2001 1998 2000 1993 2004 1973 1931 1939 ...
## $ GarageFinish : chr "RFn" "RFn" "RFn" "Unf" ...
## $ GarageCars : int 2 2 2 3 3 2 2 2 2 1 ...
## $ GarageArea : int 548 460 608 642 836 480 636 484 468 205 ...
## $ GarageQual : chr "TA" "TA" "TA" "TA" ...
## $ GarageCond : chr "TA" "TA" "TA" "TA" ...
## $ PavedDrive : chr "Y" "Y" "Y" "Y" ...
## $ WoodDeckSF : int 0 298 0 0 192 40 255 235 90 0 ...
## $ OpenPorchSF : int 61 0 42 35 84 30 57 204 0 4 ...
## $ EnclosedPorch: int 0 0 0 272 0 0 0 228 205 0 ...
## $ X3SsnPorch : int 0 0 0 0 0 320 0 0 0 0 ...
## $ ScreenPorch : int 0 0 0 0 0 0 0 0 0 0 ...
## $ PoolArea : int 0 0 0 0 0 0 0 0 0 0 ...
## $ PoolQC : chr NA NA NA NA ...
## $ Fence : chr NA NA NA NA ...
## $ MiscFeature : chr NA NA NA NA ...
## $ MiscVal : int 0 0 0 0 0 700 0 350 0 0 ...
## $ MoSold : int 2 5 9 2 12 10 8 11 4 1 ...
## $ YrSold : int 2008 2007 2008 2006 2008 2009 2007 2009 2008 2008 ...
## $ SaleType : chr "WD" "WD" "WD" "WD" ...
## $ SaleCondition: chr "Normal" "Normal" "Normal" "Abnorml" ...
## $ SalePrice : int 208500 181500 223500 140000 250000 143000 307000 200000 129900 118000 ...dim(train)
## [1] 1460 81AuxTrain<-train
AuxTest<-test
AuxTest$SalePrice<-NA
total<-rbind(AuxTrain,AuxTest)Vamos , en primer lugar, a hacer un estudio de las variables proporcionadas. Tenemos tres tipos :
| Codigo | Significado |
|---|---|
| ID | Identidad |
| LotFrontage | pies lineales de la calle conectados a la propiedad |
| LotArea | Tamaño del lote en pies cuadrados |
| YearBuilt | fecha de construcción original |
| YearRemodAdd | fecha de remodelación |
| MasVnrArea | área de chapa de la albañilería en pies cuadrados |
| BsmtFinSF1 | Tipo 1 pies cuadrados terminados |
| BsmtFinSF2 | Tipo 2 pies cuadrados terminados |
| BsmtUnfSF | Pies cuadrados sin terminar del área del sótano |
| TotalBsmtSF | pies cuadrados totales del área del sótano |
| 1stFlrSF | primer piso pies cuadrados |
| 2ndFlrSF | segundo piso pies cuadrados |
| LowQualFinSF | Pies cuadrados terminados de baja calidad (todos los pisos) |
| GrLivArea | pies cuadrados del área habitable sobre el nivel del suelo |
| BsmtFullBath | baños completos en el sótano |
| BsmtHalfBath | medio baño en el sótano |
| FullBath | baños completos por encima del grado |
| HalfBath | medio baño por encima del grado |
| Bedroom | Número de habitaciones sobre el nivel del sótano |
| Kitchen | Número de cocinas |
| TotRmsAbvGrd | Total de habitaciones por encima del grado (no incluye baños) |
| Fireplaces | cantidad de chimeneas |
| GarageYrBlt | año de garaje fue construido |
| GarageCars | tamaño del garaje en la capacidad del automóvil |
| GarageArea | Tamaño del garaje en pies cuadrados |
| WoodDeckSF | área de cubierta de madera en pies cuadrados |
| OpenPorchSF | área de porche abierto en pies cuadrados |
| EnclosedPorch | área de porche cerrado en pies cuadrados |
| 3SsnPorch | área del porche de tres estaciones en pies cuadrados |
| ScreenPorch | área del porche de la pantalla en pies cuadrados |
| PoolArea | área de la piscina en pies cuadrados |
| MiscVal | $ Valor de la función miscelánea |
| MoSold | Mes vendido |
| YrSold | Año de venta |
| SalePrice | el precio de venta de la propiedad en dólares. |
MSZoning
la clasificación general de zonificación
| Codigo | Tipo |
|---|---|
| A | Agriculture |
| C | Commercial |
| FV | Floating Village Residential |
| I | Industrial |
| RH | Residential High Density |
| RL | Residential Low Density |
| RP | Residential Low Density Park |
| RM | Residential Medium Density |
Street
Tipo de acceso por carretera
| Codigo | Tipo |
|---|---|
| Grvl | Gravel |
| Pave | Paved |
Alley
tipo de acceso a callejones
| Codigo | Tipo |
|---|---|
| Grvl | Gravel |
| Pave | Paved |
| NA | No alley access |
LotShape
forma general de la propiedad
| Codigo | Tipo |
|---|---|
| Reg | Regular |
| IR1 | Slightly irregular |
| IR2 | Moderately Irregular |
| IR3 | Irregular |
LandContour
planitud de la propiedad
| Codigo | Tipo |
|---|---|
| Lvl | Near Flat/Level |
| Bnk | Banked - Quick and significant rise from street grade to building |
| HLS | Hillside - Significant slope from side to side |
| Low | Depression |
Utilities
Tipo de utilidades disponibles
| Codigo | Tipo |
|---|---|
| AllPub | All public Utilities (E,G,W,& S) |
| NoSewr | Electricity, Gas, and Water (Septic Tank) |
| NoSewa | Electricity and Gas Only |
| ELO | Electricity only |
LotConfig
configuración del lote
| Codigo | Tipo |
|---|---|
| Inside | Inside lot |
| Corner | Corner lot |
| CulDSac | Cul-de-sac |
| FR2 | Frontage on 2 sides of property |
| FR3 | Frontage on 3 sides of property |
LandSlope
Pendiente de la propiedad
| Codigo | Tipo |
|---|---|
| Gtl | Gentle slope |
| Mod | Moderate Slope |
| Sev | Severe Slope |
Neighborhood
ubicaciones físicas dentro de los límites de la ciudad de Ames
| Codigo | Tipo |
|---|---|
| Blmngtn | Bloomington Heights |
| Blueste | Bluestem |
| BrDale | Briardale |
| BrkSide | Brookside |
| ClearCr | Clear Creek |
| CollgCr | College Creek |
| Crawfor | Crawford |
| Edwards | Edwards |
| Gilbert | Gilbert |
| IDOTRR | Iowa DOT and Rail Road |
| MeadowV | Meadow Village |
| Mitchel | Mitchell |
| NAmes | North Ames |
| NoRidge | Northridge |
| NPkVill | Northpark Villa |
| NridgHt | Northridge Heights |
| NWAmes | Northwest Ames |
| OldTown | Old Town |
| SWISU | South & West of Iowa State University |
| Sawyer | Sawyer |
| SawyerW | Sawyer West |
| Somerst | Somerset |
| StoneBr | Stone Brook |
| Timber | Timberland |
| Veenker | Veenker |
Condition1
proximidad a la carretera principal o ferrocarril
| Codigo | Tipo |
|---|---|
| Artery | Adjacent to arterial street |
| Feedr | Adjacent to feeder street |
| Norm | Normal |
| PosA | Adjacent to postive off-site feature |
| PosN | Near positive off-site feature–park, greenbelt, etc. |
| RRAe | Adjacent to East-West Railroad |
| RRAn | Adjacent to North-South Railroad |
| RRNe | Within 200’ of East-West Railroad |
| RRNn | Within 200’ of North-South Railroad |
Condition2
proximidad a la carretera principal o ferrocarril (si hay un segundo presente)
| Codigo | Tipo |
|---|---|
| Artery | Adjacent to arterial street |
| Feedr | Adjacent to feeder street |
| Norm | Normal |
| PosA | Adjacent to postive off-site feature |
| PosN | Near positive off-site feature–park, greenbelt, etc. |
| RRAe | Adjacent to East-West Railroad |
| RRAn | Adjacent to North-South Railroad |
| RRNe | Within 200’ of East-West Railroad |
| RRNn | Within 200’ of North-South Railroad |
BldgType
tipo de vivienda
| Codigo | Tipo |
|---|---|
| 1Fam | Single-family Detached |
| 2fmCon | Two-family Conversion; originally built as one-family dwelling |
| Duplex | Duplex |
| TwnhsE | Townhouse End Unit |
| Twnhs | I Townhouse Inside Unit |
HouseStyle
estilo de vivienda
| Codigo | Tipo |
|---|---|
| 1.5Fin | One and one-half story: 2nd level finished |
| 1.5Unf | One and one-half story: 2nd level unfinished |
| 1Story | One story |
| 2.5Fin | Two and one-half story: 2nd level finished |
| 2.5Unf | Two and one-half story: 2nd level unfinished |
| 2Story | Two story |
| SFoyer | Split Foyer |
| SLvl | Split Level |
RoofStyle
tipo de techo
| Codigo | Tipo |
|---|---|
| Flat | Flat |
| Gable | Gable |
| Gambrel | Gabrel (Barn) |
| Hip | Hip |
| Mansard | Mansard |
| Shed | Shed |
RoofMatl
material de techo
| Codigo | Tipo |
|---|---|
| ClyTile | Clay or Tile |
| CompShg | Standard (Composite) Shingle |
| Membran | Membrane |
| Metal | Metal |
| Roll | Roll |
| Tar&Grv | Gravel & Tar |
| WdShake | Wood Shakes |
| WdShngl | Wood Shingles |
Exterior1st
revestimiento exterior en la casa
| Codigo | Tipo |
|---|---|
| AsbShng | Asbestos Shingles |
| AsphShn | Asphalt Shingles |
| BrkComm | Brick Common |
| BrkFace | Brick Face |
| CBlock | Cinder Block |
| CemntBd | Cement Board |
| HdBoard | Hard Board |
| ImStucc | Imitation Stucco |
| MetalSd | Metal Siding |
| Other | Other |
| Plywood | Plywood |
| PreCast | PreCast |
| Stone | Stone |
| Stucco | Stucco |
| VinylSd | Vinyl Siding |
| Wd Sdng | Wood Siding |
| WdShing | Wood Shingles |
Exterior2nd
Cubierta exterior en la casa (si hay más de un material)
| Codigo | Tipo |
|---|---|
| AsbShng | Asbestos Shingles |
| AsphShn | Asphalt Shingles |
| Brk Cmn | Brick Common |
| BrkFace | Brick Face |
| CBlock | Cinder Block |
| CmentBd | Cement Board |
| HdBoard | Hard Board |
| ImStucc | Imitation Stucco |
| MetalSd | Metal Siding |
| Other | Other |
| Plywood | Plywood |
| PreCast | PreCast |
| Stone | Stone |
| Stucco | Stucco |
| VinylSd | Vinyl Siding |
| Wd Sdng | Wood Siding |
| Wd Shng | Wood Shingles |
MasVnrType
Tipo de chapa de mampostería
| Codigo | Tipo |
|---|---|
| BrkCmn | Brick Common |
| BrkFace | Brick Face |
| Cblock | Cinder Block |
| None | None |
| Stone | Stone |
ExterQual
calidad del material exterior
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| TA | Average/Typical |
| Po | Poor |
ExterCond
estado actual del material en el exterior
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| Po | Poor |
| TA | Average/Typical |
Foundation
tipo de fundación
| Codigo | Tipo |
|---|---|
| BrkTil | Brick & Tile |
| CBlock | Cinder Block |
| PConc | Poured Contrete |
| Slab | Slab |
| Stone | Stone |
| Wood | Wood |
BsmtQual
Altura del sótano
| Codigo | Tipo |
|---|---|
| Ex | Excellent (100+ inches) |
| Fa | Fair (70-79 inches) |
| Gd | Good (90-99 inches) |
| NA | No Basement |
| Po | Poor (<70 inches |
| TA | Typical (80-89 inches) |
BsmtCond
estado general del sótano
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair - dampness or some cracking or settling |
| Gd | Good |
| NA | No Basement |
| Po | Poor - Severe cracking, settling, or wetness |
| TA | Typical - slight dampness allowed |
BsmtExposure
muros de sotano a ras de suelo o de jardín
| Codigo | Tipo |
|---|---|
| Av | Average Exposure (split levels or foyers typically score average or above) |
| Gd | Good Exposure |
| Mn | Mimimum Exposure |
| NA | No Basement |
| No | No Exposure |
BsmtFinType1
Calidad del área acabada del sótano
| Codigo | Tipo |
|---|---|
| ALQ | Average Living Quarters |
| BLQ | Below Average Living Quarters |
| GLQ | Good Living Quarters |
| LwQ | Low Quality |
| NA | No Basement |
| Rec | Average Rec Room |
| Unf | Unfinshed |
BsmtFinType2
Calidad del segundo área terminada (si está presente)
| Codigo | Tipo |
|---|---|
| ALQ | Average Living Quarters |
| BLQ | Below Average Living Quarters |
| GLQ | Good Living Quarters |
| LwQ | Low Quality |
| NA | No Basement |
| Rec | Average Rec Room |
| Unf | Unfinshed |
Heating
tipo de calefacción
| Codigo | Tipo |
|---|---|
| Floor | Floor Furnace |
| GasA | Gas forced warm air furnace |
| GasW | Gas hot water or steam heat |
| Grav | Gravity furnace |
| OthW | Hot water or steam heat other than gas |
| Wall | Wall furnace |
HeatingQC
Calidad y condición de la calefacción
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| Po | Poor |
| TA | Average/Typical |
CentralAir
Aire acondicionado central
| Codigo | Tipo |
|---|---|
| N | No |
| Y | Yes |
Electrical
sistema eléctrico
| Codigo | Tipo |
|---|---|
| FuseA | Fuse Box over 60 AMP and all Romex wiring (Average) |
| FuseF | 60 AMP Fuse Box and mostly Romex wiring (Fair) |
| FuseP | 60 AMP Fuse Box and mostly knob & tube wiring (poor) |
| Mix | Mixed |
| SBrkr | Standard Circuit Breakers & Romex |
KitchenQual
calidad de la cocina
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| Po | Poor |
| TA | Typical/Average |
Functional
calificación de la funcionalidad del hogar
| Codigo | Tipo |
|---|---|
| Maj1 | Major Deductions 1 |
| Maj2 | Major Deductions 2 |
| Min1 | Minor Deductions 1 |
| Min2 | Minor Deductions 2 |
| Mod | Moderate Deductions |
| Sal | Salvage only |
| Sev | Severely Damaged |
| Typ | Typical Functionality |
FireplaceQu
calidad de la chimenea
| Codigo | Tipo |
|---|---|
| Ex | Excellent - Exceptional Masonry Fireplace |
| Fa | Fair - Prefabricated Fireplace in basement |
| Gd | Good - Masonry Fireplace in main level |
| NA | No Fireplace |
| Po | Poor - Ben Franklin Stove |
| TA | Average - Prefabricated Fireplace in main living area or Masonry Fireplace in basement |
GarageType
ubicación del garaje
| Codigo | Tipo |
|---|---|
| 2Types | More than one type of garage |
| Attchd | Attached to home |
| Basment | Basement Garage |
| BuiltIn | Built-In (Garage part of house - typically has room above garage) |
| CarPort | Car Port |
| Detchd | Detached from home |
| NA | No Garage |
GarageFinish
acabado interior del garaje
| Codigo | Tipo |
|---|---|
| Fin | Finished |
| RFn | Rough Finished |
| Unf | Unfinished |
| NA | No Garage |
GarageQual
calidad de garaje
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| NA | No Garage |
| Po | Poor |
| TA | Typical/Average |
GarageCond
condición de garaje
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| NA | No Garage |
| Po | Poor |
| TA | Typical/Average |
PavedDrive
calzada pavimentada
| Codigo | Tipo |
|---|---|
| N | Dirt/Gravel |
| P | Partial Pavement |
| Y | Paved |
PoolQC
calidad de la piscina
| Codigo | Tipo |
|---|---|
| Ex | Excellent |
| Fa | Fair |
| Gd | Good |
| NA | No Pool |
| TA | Average/Typical |
Fence
calidad de la cerca
| Codigo | Tipo |
|---|---|
| GdPrv | Good Privacy |
| GdWo | Good Wood |
| MnPrv | Minimum Privacy |
| MnWw | Minimum Wood/Wire |
| NA | No Fence |
MiscFeature
característica miscelánea no cubierta en otras categorías
| Codigo | Tipo |
|---|---|
| Elev | Elevator |
| Gar2 | 2nd Garage (if not described in garage section) |
| NA | None |
| Othr | Other |
| Shed | Shed (over 100 SF) |
| TenC | Tennis Court |
SaleType
Tipo de venta
| Codigo | Tipo |
|---|---|
| COD | Court Officer Deed/Estate |
| Con | Contract 15% Down payment regular terms |
| ConLD | Contract Low Down |
| ConLI | Contract Low Interest |
| ConLw | Contract Low Down payment and low interest |
| CWD | Warranty Deed - Cash |
| New | Home just constructed and sold |
| Oth | Other |
| VWD | Warranty Deed - VA Loan |
| WD | Warranty Deed - Conventional |
SaleCondition
Condiciones de venta
| Codigo | Tipo |
|---|---|
| Abnorml | Abnormal Sale - trade, foreclosure, short sale |
| AdjLand | Adjoining Land Purchase |
| Alloca | Allocation - two linked properties with separate deeds, typically condo with a garage unit |
| Family | Sale between family members |
| Normal | Normal Sale |
| Partial | Home was not completed when last assessed (associated with New Homes) |
Estas tienen la peculiaridad de que tienen asignada una numeración aunque realmente son categóricas
MSSubClass
la clase de construcción
| Codigo | Tipo |
|---|---|
| 20 | 1-STORY 1946 & NEWER ALL STYLES |
| 30 | 1-STORY 1945 & OLDER |
| 40 | 1-STORY W/FINISHED ATTIC ALL AGES |
| 45 | 1-1/2 STORY - UNFINISHED ALL AGES |
| 50 | 1-1/2 STORY FINISHED ALL AGES |
| 60 | 2-STORY 1946 & NEWER |
| 70 | 2-STORY 1945 & OLDER |
| 75 | 2-1/2 STORY ALL AGES |
| 80 | SPLIT OR MULTI-LEVEL |
| 85 | SPLIT FOYER |
| 90 | DUPLEX - ALL STYLES AND AGES |
| 120 | 1-STORY PUD (Planned Unit Development) - 1946 & NEWER |
| 150 | 1-1/2 STORY PUD - ALL AGES |
| 160 | 2-STORY PUD - 1946 & NEWER |
| 180 | PUD - MULTILEVEL - INCL SPLIT LEV/FOYER |
| 190 | 2 FAMILY CONVERSION - ALL STYLES AND AGES |
OverallQual
material general y calidad de acabado
| Codigo | Tipo |
|---|---|
| 10 | Very Excellent |
| 9 | Excellent |
| 8 | Very Good |
| 7 | Good |
| 6 | Above Average |
| 5 | Average |
| 4 | Below Average |
| 3 | Fair |
| 2 | Poor |
| 1 | Very Poor |
OverallCond
calificación de la condición general
| Codigo | Tipo |
|---|---|
| 10 | Very Excellent |
| 9 | Excellent |
| 8 | Very Good |
| 7 | Good |
| 6 | Above Average |
| 5 | Average |
| 4 | Below Average |
| 3 | Fair |
| 2 | Poor |
| 1 | Very Poor |
Veamos primero cuantos valores y en cuantas columnas tenemos NA
columnasNA <- which(colSums(is.na(total)) > 0)
kable(sort(colSums(sapply(total[columnasNA], is.na)), decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| x | |
|---|---|
| PoolQC | 2909 |
| MiscFeature | 2814 |
| Alley | 2721 |
| Fence | 2348 |
| SalePrice | 1459 |
| FireplaceQu | 1420 |
| LotFrontage | 486 |
| GarageYrBlt | 159 |
| GarageFinish | 159 |
| GarageQual | 159 |
| GarageCond | 159 |
| GarageType | 157 |
| BsmtCond | 82 |
| BsmtExposure | 82 |
| BsmtQual | 81 |
| BsmtFinType2 | 80 |
| BsmtFinType1 | 79 |
| MasVnrType | 24 |
| MasVnrArea | 23 |
| MSZoning | 4 |
| Utilities | 2 |
| BsmtFullBath | 2 |
| BsmtHalfBath | 2 |
| Functional | 2 |
| Exterior1st | 1 |
| Exterior2nd | 1 |
| BsmtFinSF1 | 1 |
| BsmtFinSF2 | 1 |
| BsmtUnfSF | 1 |
| TotalBsmtSF | 1 |
| Electrical | 1 |
| KitchenQual | 1 |
| GarageCars | 1 |
| GarageArea | 1 |
| SaleType | 1 |
Veamos un listado de los valores NA usados como categoria
Estaban marcados en rojo en su respectiva tabla
Alley tipo de acceso a callejones
| Codigo | Significado |
|---|---|
| NA | No alley access |
BsmtQual Altura del sótano
| Codigo | Significado |
|---|---|
| NA | No Basement |
BsmtCond estado general del sótano
| Codigo | Significado |
|---|---|
| NA | No Basement |
BsmtExposure muros de sotano a ras de suelo o de jardín
| Codigo | Significado |
|---|---|
| NA | No Basement |
BsmtFinType1 Calidad del área acabada del sótano
| Codigo | Significado |
|---|---|
| NA | No Basement |
BsmtFinType2 Calidad del segundo área terminada (si está presente)
| Codigo | Significado |
|---|---|
| NA | No Basement |
FireplaceQu calidad de la chimenea
| Codigo | Significado |
|---|---|
| NA | No Fireplace |
GarageType ubicación del garaje
| Codigo | Significado |
|---|---|
| NA | No Garage |
GarageFinish acabado interior del garaje
| Codigo | Significado |
|---|---|
| NA | No Garage |
GarageQual calidad de garaje
| Codigo | Significado |
|---|---|
| NA | No Garage |
GarageCond condición de garaje
| Codigo | Significado |
|---|---|
| NA | No Garage |
PoolQC calidad de la piscina
| Codigo | Significado |
|---|---|
| NA | No Pool |
Fence calidad de la cerca
| Codigo | Significado |
|---|---|
| NA | No Fence |
MiscFeature característica miscelánea no cubierta en otras categorías
| Codigo | Significado |
|---|---|
| NA | None |
Podemos apreciar que en todas las variables donde aparece (Callejon, Sotanos, Garages, Piscinas, Cerca y Varios), el sentido que se le da es “Ninguno” o “No existe”.
Por lo que podemos cambiar el código en esas variables por NONE
#Cambio los NA por NONE en cada variable
total$Alley[is.na(total$Alley)]<-'NONE'
total$BsmtQual[is.na(total$BsmtQual)]<-'NONE'
total$BsmtCond[is.na(total$BsmtCond)]<-'NONE'
total$BsmtExposure[is.na(total$BsmtExposure)]<-'NONE'
total$BsmtFinType1[is.na(total$BsmtFinType1)]<-'NONE'
total$BsmtFinType2[is.na(total$BsmtFinType2)]<-'NONE'
total$FireplaceQu[is.na(total$FireplaceQu)]<-'NONE'
total$GarageType[is.na(total$GarageType)]<-'NONE'
total$GarageFinish[is.na(total$GarageFinish)]<-'NONE'
total$GarageQual[is.na(total$GarageQual)]<-'NONE'
total$GarageCond[is.na(total$GarageCond)]<-'NONE'
total$PoolQC[is.na(total$PoolQC)]<-'NONE'
total$Fence[is.na(total$Fence)]<-'NONE'
total$MiscFeature[is.na(total$MiscFeature)]<-'NONE'Volvemos a comprobar cuantas columnas quedan con valores NA
columnasNA <- which(colSums(is.na(total)) > 0)
kable(sort(colSums(sapply(total[columnasNA], is.na)), decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| x | |
|---|---|
| SalePrice | 1459 |
| LotFrontage | 486 |
| GarageYrBlt | 159 |
| MasVnrType | 24 |
| MasVnrArea | 23 |
| MSZoning | 4 |
| Utilities | 2 |
| BsmtFullBath | 2 |
| BsmtHalfBath | 2 |
| Functional | 2 |
| Exterior1st | 1 |
| Exterior2nd | 1 |
| BsmtFinSF1 | 1 |
| BsmtFinSF2 | 1 |
| BsmtUnfSF | 1 |
| TotalBsmtSF | 1 |
| Electrical | 1 |
| KitchenQual | 1 |
| GarageCars | 1 |
| GarageArea | 1 |
| SaleType | 1 |
Vemos ahora las variables que nos quedan por comprobar
GarageYrBlt --> 159 registros GarageCars --> 1 registros GarageArea --> 1 registros
Vamos a ver con que valores de GarageType se correponden estos NA
prueba<-total%>%filter(is.na(total$GarageYrBlt))%>%select(Id,GarageType)
prueba[,2]<-as.factor(prueba[,2])
levels(prueba[,2])
## [1] "Detchd" "NONE"
Seleccionamos especificamente los registros que no tienen garaje
Ponemos a 0 el año en aquellos que no tienen garage
prueba<-total%>%filter(is.na(total$GarageYrBlt))%>%filter(GarageType=='NONE')%>%select(Id,GarageType)
total[prueba[,1],60]<-0
Vemos los registros que nos han quedado
prueba<-total%>%filter(is.na(total$GarageYrBlt))%>%select(Id,GarageType,GarageYrBlt,GarageFinish,GarageCars,GarageArea,GarageQual,GarageCond)
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | GarageType | GarageYrBlt | GarageFinish | GarageCars | GarageArea | GarageQual | GarageCond |
|---|---|---|---|---|---|---|---|
| 2127 | Detchd | NA | NONE | 1 | 360 | NONE | NONE |
| 2577 | Detchd | NA | NONE | NA | NA | NONE | NONE |
Parece claro que este registro no tiene garage
total[2577,59]<-'NONE'
total[2577,60]<-0
total[2577,62]<-0
total[2577,63]<-0
Buscamos registros con GarageType y GarageCars iguales al registro 2127 y seleccionamos los mas usados
prueba2<-total%>%filter(GarageType=="Detchd"&GarageCars==1)%>%select(Id,YearBuilt,YearRemodAdd,GarageType,GarageYrBlt,GarageFinish,GarageCars,GarageArea,GarageQual,GarageCond)
freq<-as.data.frame(table(prueba2$GarageFinish,prueba2$GarageQual,prueba2$GarageCond))
kable(head(freq[order(freq$Freq,decreasing = TRUE),]))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Var2 | Var3 | Freq | |
|---|---|---|---|---|
| 144 | Unf | TA | TA | 268 |
| 128 | Unf | Fa | TA | 40 |
| 32 | Unf | Fa | Fa | 25 |
| 48 | Unf | TA | Fa | 18 |
| 143 | RFn | TA | TA | 6 |
| 104 | Unf | Fa | Po | 4 |
Asignamos
total[2127,61]<-"Unf"
total[2127,64]<-"TA"
total[2127,65]<-"TA"
Miramos el valor superior entre YearBuilt y YearRemodAdd y lo asignamos a GarageYrBlt
kable(total%>%filter(Id==2127)%>%select(YearBuilt,YearRemodAdd))| YearBuilt | YearRemodAdd |
|---|---|
| 1910 | 1983 |
total[2127,60]<-1983
BsmtFullBath --> 2 registros BsmtHalfBath --> 2 registros BsmtFinSF1 --> 1 registro BsmtFinSF2 --> 1 registro BsmtUnfSF --> 1 registro TotalBsmtSF --> 1 registro
prueba<-total%>%filter(is.na(BsmtFullBath)|is.na(BsmtHalfBath))%>%select(Id,BsmtQual,BsmtCond,BsmtExposure,BsmtFinType1,BsmtFinSF1,BsmtFinType2,BsmtFinSF2,BsmtUnfSF,BsmtFullBath,BsmtHalfBath,TotalBsmtSF)
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | BsmtQual | BsmtCond | BsmtExposure | BsmtFinType1 | BsmtFinSF1 | BsmtFinType2 | BsmtFinSF2 | BsmtUnfSF | BsmtFullBath | BsmtHalfBath | TotalBsmtSF |
|---|---|---|---|---|---|---|---|---|---|---|---|
| 2121 | NONE | NONE | NONE | NONE | NA | NONE | NA | NA | NA | NA | NA |
| 2189 | NONE | NONE | NONE | NONE | 0 | NONE | 0 | 0 | NA | NA | 0 |
Evidentemente ninguno de estos dos registros tiene sotano por lo que los registros que están con NA hay que ponerlos a 0
total[2121,35]<-0
total[2121,37]<-0
total[2121,38]<-0
total[2121,39]<-0
total[2121,48]<-0
total[2121,49]<-0
total[2189,48]<-0
total[2189,49]<-0Verificamos campos discordantes de sotano
prueba<-total%>%filter(BsmtCond=='NONE'|BsmtQual=='NONE'|BsmtExposure=='NONE'|BsmtFinType1=='NONE'|BsmtFinType2=='NONE')%>%select(Id,BsmtCond,BsmtQual,BsmtExposure,BsmtFinType1,BsmtFinSF1,BsmtFinType2,BsmtFinSF2,BsmtUnfSF,TotalBsmtSF,BsmtFullBath,BsmtHalfBath)
kable(prueba%>%filter(BsmtCond!='NONE'|BsmtQual!='NONE'|BsmtExposure!='NONE'|BsmtFinType1!='NONE'|BsmtFinType2!='NONE'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | BsmtCond | BsmtQual | BsmtExposure | BsmtFinType1 | BsmtFinSF1 | BsmtFinType2 | BsmtFinSF2 | BsmtUnfSF | TotalBsmtSF | BsmtFullBath | BsmtHalfBath |
|---|---|---|---|---|---|---|---|---|---|---|---|
| 333 | TA | Gd | No | GLQ | 1124 | NONE | 479 | 1603 | 3206 | 1 | 0 |
| 949 | TA | Gd | NONE | Unf | 0 | Unf | 0 | 936 | 936 | 0 | 0 |
| 1488 | TA | Gd | NONE | Unf | 0 | Unf | 0 | 1595 | 1595 | 0 | 0 |
| 2041 | NONE | Gd | Mn | GLQ | 1044 | Rec | 382 | 0 | 1426 | 1 | 0 |
| 2186 | NONE | TA | No | BLQ | 1033 | Unf | 0 | 94 | 1127 | 0 | 1 |
| 2218 | Fa | NONE | No | Unf | 0 | Unf | 0 | 173 | 173 | 0 | 0 |
| 2219 | TA | NONE | No | Unf | 0 | Unf | 0 | 356 | 356 | 0 | 0 |
| 2349 | TA | Gd | NONE | Unf | 0 | Unf | 0 | 725 | 725 | 0 | 0 |
| 2525 | NONE | TA | Av | ALQ | 755 | Unf | 0 | 240 | 995 | 0 | 0 |
Procedemos a modificar los campos discordantes por registros similares
Buscamos registros parecidos y asignamos
prueba1<-total%>%filter(BsmtCond=='TA'& BsmtQual=='Gd'& BsmtExposure=='No'& BsmtFinType1=='GLQ' & BsmtFinType2!='Unf' & BsmtFullBath==1)%>%select(Id,BsmtCond,BsmtQual,BsmtExposure,BsmtFinType1,BsmtFinSF1,BsmtFinType2,BsmtFinSF2,BsmtUnfSF,TotalBsmtSF,BsmtFullBath,BsmtHalfBath)
sort(table(prueba1$BsmtFinType2),decreasing = TRUE)
##
## ALQ Rec BLQ LwQ NONE
## 4 2 1 1 1
total[333,36]<-'ALQ'
Estos tres registros coinciden en los campos salvo en BsmtUnSF
Buscamos registros parecidos, comparamos y asignamos
prueba1<-total%>%filter( BsmtFinType1=='Unf' & BsmtCond=='TA'& BsmtQual=='Gd' )%>%select(Id,BsmtExposure,BsmtUnfSF,TotalBsmtSF)
table(prueba1$BsmtExposure)
##
## Av Gd Mn No NONE
## 58 10 22 255 3
prop.table(table(prueba1$BsmtExposure))
##
## Av Gd Mn No NONE
## 0.16666667 0.02873563 0.06321839 0.73275862 0.00862069
muro<-ggplot(prueba1,aes(x=BsmtExposure,y=BsmtUnfSF))
muro<-muro+geom_boxplot(varwidth = TRUE)
muro
No se aprecia relacion evidente entre el tamaño del sotano y el tipo de muro.
Ademas el campo con mas casos tiene casi un 75%. Lo aplicamos en estos registros
total[949,33]<-'No'
total[1488,33]<-'No'
total[2349,33]<-'No'
No tienen campos en comun. Buscamos por el valor mas representativo
table(total$BsmtCond)
##
## Fa Gd NONE Po TA
## 104 122 82 5 2606Asignamos el valor TA
total[2041,32]<-'TA'
total[2186,32]<-'TA'
total[2525,32]<-'TA'
Buscamos registros con campos comunes iguales
prueba1<-total%>%filter( BsmtExposure=='No' & BsmtFinType1=='Unf' )%>%select(Id,BsmtCond,BsmtQual,TotalBsmtSF)
kable(table(prueba1$BsmtQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| Ex | 26 |
| Fa | 54 |
| Gd | 269 |
| NONE | 2 |
| TA | 338 |
Estan repartidos. Hay que buscar mas
Filtro por el campo BsmtCond que es diferente en cada registro
prueba1<-total%>%filter( BsmtCond=='Fa' & BsmtExposure=='No' & BsmtFinType1=='Unf' )%>%select(Id,BsmtCond,BsmtQual,TotalBsmtSF)
kable(table(prueba1$BsmtQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| Fa | 13 |
| Gd | 2 |
| NONE | 1 |
| TA | 31 |
prueba1<-total%>%filter( BsmtCond=='TA' & BsmtExposure=='No' & BsmtFinType1=='Unf' )%>%select(Id,BsmtCond,BsmtQual,TotalBsmtSF)
kable(table(prueba1$BsmtQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| Ex | 20 |
| Fa | 38 |
| Gd | 258 |
| NONE | 1 |
| TA | 304 |
En ambos casos el valor mas usado es ‘TA’. Lo aplicamos
total[2218,31]<-'TA'
total[2219,31]<-'TA'
MasVnrType --> 24 registros MaVnrArea --> 23 registros
Vamos a ver los registros con NA relacionados con la albañileria
prueba<-total%>%filter(is.na(MasVnrType))%>%select(Id,MasVnrType,MasVnrArea)
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | MasVnrType | MasVnrArea |
|---|---|---|
| 235 | NA | NA |
| 530 | NA | NA |
| 651 | NA | NA |
| 937 | NA | NA |
| 974 | NA | NA |
| 978 | NA | NA |
| 1244 | NA | NA |
| 1279 | NA | NA |
| 1692 | NA | NA |
| 1707 | NA | NA |
| 1883 | NA | NA |
| 1993 | NA | NA |
| 2005 | NA | NA |
| 2042 | NA | NA |
| 2312 | NA | NA |
| 2326 | NA | NA |
| 2341 | NA | NA |
| 2350 | NA | NA |
| 2369 | NA | NA |
| 2593 | NA | NA |
| 2611 | NA | 198 |
| 2658 | NA | NA |
| 2687 | NA | NA |
| 2863 | NA | NA |
Uno de los elementos a seleccionar en MasVnrType es None. Ponemos los NA como None y el area a 0
total$MasVnrArea[is.na(total$MasVnrType)==TRUE]<-0
total$MasVnrType[is.na(total$MasVnrType)==TRUE]<-'None'
Compruebo si estan bien todos las areas con un tipo None
prueba<-total%>%filter(MasVnrType=='None' & MasVnrArea>0)%>%select(Id,MasVnrArea)
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | MasVnrArea |
|---|---|
| 625 | 288 |
| 774 | 1 |
| 1231 | 1 |
| 1301 | 344 |
| 1335 | 312 |
| 1670 | 285 |
| 2453 | 1 |
Tenemos 7 registros que no tienen el area a 0 y no tienen mamposteria
total$MasVnrArea[total$MasVnrType=='None'& total$MasVnrArea>0]<-0
Compruebo si estan bien todos las areas con valor 0 sin tener un tipo None
prueba<-total%>%filter(MasVnrType!='None' & MasVnrArea==0)%>%select(Id,MasVnrType,MasVnrArea)
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | MasVnrType | MasVnrArea |
|---|---|---|
| 689 | BrkFace | 0 |
| 1242 | Stone | 0 |
| 2320 | BrkFace | 0 |
Hay tres registros. Como no hay forma de saber el tipo de manposteria, la ponemos como ninguna
total[689,26]<-'None'
total[1242,26]<-'None'
total[2320,26]<-'None'
LotFrontage --> 486 registros
Tenemos 486 registros con NA.
Este es un campo cuantitativo por lo que resultan mas difíciles de definir que los categóricos. Aquí buscamos en pies la longitud de la propiedad que limita con la calle.
Para poder calcularlo vamos a tener en cuenta que conocemos
LotArea área de la propiedad , que es cuantitativo,LotShape , que es un factor que indica la configuración de la planta de la propiedadLotConfig otro factor importante en Real State que indica la forma de la propiedad respecto a su entornoNeighborhood, que es el entorno donde esta situadaPara obtener un valor que pueda ser comparado vamos a calcular la relación entre la fachada y la raíz cuadrada del área.
La forma que tiene la propiedad puede ser cuadrada, rectangular, trapezoidal, triangular, de forma irregular, etc. Elegimos la raíz cuadradada del lado de un cuadrado y calculamos la proporción entre el lado del cuadrado que tendría ese área y la longitud real de la fachada.
Esa medida la vamos a agrupar por el vecindario (Neighborhood), la forma de la propiedad (LotConfig) y la regularidad de esa forma (LotShape)
Recomendado:
https://en.wikipedia.org/wiki/Land_lot
http://www.gimme-shelter.com/frontage-50043/
#registros con NA
prueba1<-total%>%filter(is.na(LotFrontage)==TRUE)
options(digits=4)
#resto de registros agrupados
prueba2<-total%>%filter(is.na(LotFrontage)==FALSE)%>%group_by(LotShape,LotConfig,Neighborhood)
#Calculo proporcion
prueba2[,82]<-prueba2$LotFrontage/sqrt(prueba2$LotArea)
#Numero y media de las proporciones por agrupaciones
prueba3<-prueba2%>%summarise(cuenta=n(),media=mean(V82))
# De cada registro con NA buscamos que agrupacion le corresponde y le asignamos la proporcion que le corresponde de su grupo adecuada a su area propia
for (i in 1:length(prueba1$Id)){
lista<-which((prueba1[i,11]==prueba3$LotConfig)&(prueba1[i,8]==prueba3$LotShape)&(prueba1[i,13]==prueba3$Neighborhood))
prueba1[i,82]<-round(prueba3[lista[1],5]*sqrt(prueba1[i,5]))
}
nrow(table(prueba1%>%filter(is.na(media)==TRUE)))
## [1] 40Faltan 40 registros que no estan conformados por los tres campos.
Reducimos las agrupaciones a dos. LotConfig y Neighborhood
Realizamos las mismas operaciones que en el chunk anterior
prueba11<-prueba1%>%filter(is.na(media)==TRUE)
prueba22<-total%>%filter(is.na(LotFrontage)==FALSE)%>%group_by(LotConfig,Neighborhood)
prueba22[,82]<-prueba22$LotFrontage/sqrt(prueba22$LotArea)
prueba23<-prueba22%>%summarise(cuenta=n(),media=mean(V82))
for (i in 1:length(prueba11$Id)){
lista<-which((prueba11[i,11]==prueba23$LotConfig)&(prueba11[i,13]==prueba23$Neighborhood))
prueba11[i,82]<-round(prueba23[lista[1],4]*sqrt(prueba11[i,5]))
}
nrow(table(prueba11%>%filter(is.na(media)==TRUE)))
## [1] 4Faltan 4 registros que no estan conformados por los dos campos.
Reducimos a Neighborhood y realizamos las misma operaciones
prueba111<-prueba11%>%filter(is.na(media)==TRUE)
prueba222<-total%>%filter(is.na(LotFrontage)==FALSE)%>%group_by(Neighborhood)
prueba222[,82]<-prueba222$LotFrontage/sqrt(prueba222$LotArea)
prueba223<-prueba222%>%summarise(cuenta=n(),media=mean(V82))
for (i in 1:length(prueba111$Id)){
lista<-which(prueba111[i,13]==prueba223$Neighborhood)
prueba111[i,82]<-round(prueba223[lista[1],3]*sqrt(prueba111[i,5]))
}
nrow(table(prueba111%>%filter(is.na(media)==TRUE)))
## [1] 0Ya no quedan registros sin NA en media. Unimos todos los grupos de registros que hemos hecho registros. Reasignamos el valor de media a LotFrontage y ordenamos el conjunto
prueba<-rbind(prueba1[is.na(prueba1$media)==FALSE,],prueba11[is.na(prueba11$media)==FALSE,],prueba111[is.na(prueba111$media)==FALSE,])
prueba$LotFrontage<-prueba$media
total<-rbind(total[is.na(total$LotFrontage)==FALSE,],prueba[,1:81])
#reordenamos
total<-total%>%arrange(Id)
Exterior1st --> 1 registro Exterior2nd --> 1 registro
Tenemos dos variables categóricas con 1 NA cada una en el mismo registro.
kable(total%>%filter(is.na(Exterior1st)==TRUE)%>%select(Id,Exterior1st,Exterior2nd))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | Exterior1st | Exterior2nd |
|---|---|---|
| 2152 | NA | NA |
kable(sort(table(total$Exterior1st),decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| VinylSd | 1025 |
| MetalSd | 450 |
| HdBoard | 442 |
| Wd Sdng | 411 |
| Plywood | 221 |
| CemntBd | 126 |
| BrkFace | 87 |
| WdShing | 56 |
| AsbShng | 44 |
| Stucco | 43 |
| BrkComm | 6 |
| AsphShn | 2 |
| CBlock | 2 |
| Stone | 2 |
| ImStucc | 1 |
kable(sort(table(total$Exterior2nd),decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| VinylSd | 1014 |
| MetalSd | 447 |
| HdBoard | 406 |
| Wd Sdng | 391 |
| Plywood | 270 |
| CmentBd | 126 |
| Wd Shng | 81 |
| BrkFace | 47 |
| Stucco | 47 |
| AsbShng | 38 |
| Brk Cmn | 22 |
| ImStucc | 15 |
| Stone | 6 |
| AsphShn | 4 |
| CBlock | 3 |
| Other | 1 |
Sin mas información escogemos lo mas frecuente
total[2152,24]<-'VinylSD'
total[2152,25]<-'VinylSD'
Utilities --> 2 registros
Tenemos 2 registros con NA en este campo
Vemos como estan distribuidos
kable(total%>%filter(is.na(Utilities)==TRUE)%>%select(Id,Utilities))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | Utilities |
|---|---|
| 1916 | NA |
| 1946 | NA |
kable(sort(table(total$Utilities),decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| AllPub | 2916 |
| NoSeWa | 1 |
Como parece evidente ponemos estos dos registros como la inmensa mayoría. Aunque tenerlos casi todos iguales no servirá para predecir nada
total[1916,10]<-'AllPub'
total[1946,10]<-'AllPub'
Functional --> 2 registros
Tenemos 2 registros con NA en este campo
kable(total%>%filter(is.na(Functional)==TRUE)%>%select(Id,Functional))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | Functional |
|---|---|
| 2217 | NA |
| 2474 | NA |
kable(sort(table(total$Functional),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| Typ | 2717 |
| Min2 | 70 |
| Min1 | 65 |
| Mod | 35 |
| Maj1 | 19 |
| Maj2 | 9 |
| Sev | 2 |
Ponemos estos registros como Typical que son la mayoría. No tenemos información para mas
total[2217,56]<-'Typ'
total[2474,56]<-'Typ'
Electrical --> 1 registro
Tenemos 1 registro con NA en este campo
kable(total%>%filter(is.na(Electrical)==TRUE)%>%select(Id,Electrical))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | Electrical |
|---|---|
| 1380 | NA |
kable(sort(table(total$Electrical),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| SBrkr | 2671 |
| FuseA | 188 |
| FuseF | 50 |
| FuseP | 8 |
| Mix | 1 |
Ponemos este registro como la mayoría, el estándar
total[1380,43]<-'SBrkr'
KitchenQual --> 1 registro
Tenemos 1 registro con NA
kable(total%>%filter(is.na(KitchenQual)==TRUE)%>%select(Id,KitchenQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | KitchenQual |
|---|---|
| 1556 | NA |
kable(sort(table(total$KitchenQual),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| TA | 1492 |
| Gd | 1151 |
| Ex | 205 |
| Fa | 70 |
Como solo es un registro podemos ponerle el valor mayoritario sin que afecte mucho
total[1556,54]<-'TA'Por otro lado tenemos tres registros con un numero de cocinas por encima del suelo igual a 0, pero sin embargo su calidad es Typical
kable(total%>%filter(KitchenAbvGr==0)%>%select(Id,KitchenAbvGr,KitchenQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | KitchenAbvGr | KitchenQual |
|---|---|---|
| 955 | 0 | TA |
| 2588 | 0 | TA |
| 2860 | 0 | TA |
En principio no es paradójico puesto que no existe la opción de NONE en KitchenQual
SaleType --> 1 registro
Tenemos 1 registro con NA en el campo SaleType
kable(total%>%filter(is.na(SaleType)==TRUE)%>%select(Id))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id |
|---|
| 2490 |
kable(sort(table(total$SaleType),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| WD | 2525 |
| New | 239 |
| COD | 87 |
| ConLD | 26 |
| CWD | 12 |
| ConLI | 9 |
| ConLw | 8 |
| Oth | 7 |
| Con | 5 |
Como solo es un registro podemos ponerle el valor mayoritario sin que afecte mucho
total[2490,79]<-'WD'
MSZoning --> 4 registro
Tenemos 4 registros con NA
kable(total%>%filter(is.na(MSZoning)==TRUE)%>%select(Id))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id |
|---|
| 1916 |
| 2217 |
| 2251 |
| 2905 |
kable(sort(table(total$MSZoning),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| RL | 2265 |
| RM | 460 |
| FV | 139 |
| RH | 26 |
| C (all) | 25 |
En este caso vamos a ver la relación entre el tipo de zonificación y el barrio, MSZoning y Neighborhood
plotPru<-ggplot(data=total,aes(x=total$Neighborhood,y=total$MSZoning))
plotPru<-plotPru+geom_count()+labs(x="BARRIOS",y="ZONIFICACION")
plotPru<-plotPru+theme(axis.text.x = element_text(angle = 90,hjust=1,vjust=0.5),title = element_text(color="blue",size=12,lineheight = 1))
plotPru
Compruebo los registros con NA
kable(total%>%filter(is.na(MSZoning)==TRUE)%>%select(Id,MSZoning,Neighborhood))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | MSZoning | Neighborhood |
|---|---|---|
| 1916 | NA | IDOTRR |
| 2217 | NA | IDOTRR |
| 2251 | NA | IDOTRR |
| 2905 | NA | Mitchel |
A destacar:
IDOTRR donde tenemos tres registros no existe ninguna vivienda zonificada como RL que es la mayoritaria en el conjunto de Ames.Mitchel , donde esta el otro registro, sí es RL la mayoritariaVuelvo a comprobar separando los barrios. Para los registros del barrio de IDOTRR
prueba1<-total%>%filter(is.na(MSZoning)==FALSE)%>%filter(Neighborhood=='IDOTRR')
kable(sort(table(prueba1$MSZoning),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| RM | 68 |
| C (all) | 22 |
Escojo como valor mayoritario RM
total[1916,3]<-'RM'
total[2217,3]<-'RM'
total[2251,3]<-'RM'Para el otro barrio
prueba1<-total%>%filter(is.na(MSZoning)==FALSE)%>%filter(Neighborhood=='Mitchel')
kable(sort(table(prueba1$MSZoning),decreasing=TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| RL | 104 |
| RM | 9 |
Escojo como valor mas usado RL
total[2905,3]<-'RL'
Comprobamos cuantos valores nos quedan con NA
#Comprobamos cuantos NA nos quedan
ColumnasNA <- which(colSums(is.na(total)) > 0)
kable(sort(colSums(sapply(total[ColumnasNA], is.na)), decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| x | |
|---|---|
| SalePrice | 1459 |
Que es la variable objetivo
Vamos a buscar contradicciones entre características similares
No se puede establecer una relacion directa entre la calidad de la piscina y el area. Buscamos en la calidad general de la casa
kable(total%>%filter(PoolArea>0 & PoolQC=='NONE')%>%select(Id,PoolQC,PoolArea))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | PoolQC | PoolArea |
|---|---|---|
| 2421 | NONE | 368 |
| 2504 | NONE | 444 |
| 2600 | NONE | 561 |
Tenemos tres registros que tienen un area de piscina sin tenerla
Vemos como están distribuidas las piscinas
kable(sort(table(total$PoolQC),decreasing = TRUE))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| NONE | 2909 |
| Ex | 4 |
| Gd | 4 |
| Fa | 2 |
La gran mayoría de las casas no tienen piscina. Para poder encontrar un criterio con el que dar una cualificación a los registros que faltan buscaremos algún tipo de relación
prueba<-total%>%filter(PoolArea>0 )%>%select(Id,PoolQC,PoolArea,OverallQual,OverallCond)
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | PoolQC | PoolArea | OverallQual | OverallCond |
|---|---|---|---|---|
| 198 | Ex | 512 | 8 | 4 |
| 811 | Fa | 648 | 6 | 6 |
| 1171 | Gd | 576 | 6 | 6 |
| 1183 | Ex | 555 | 10 | 5 |
| 1299 | Gd | 480 | 10 | 5 |
| 1387 | Fa | 519 | 7 | 5 |
| 1424 | Gd | 738 | 6 | 7 |
| 1975 | Ex | 144 | 10 | 5 |
| 2421 | NONE | 368 | 4 | 6 |
| 2504 | NONE | 444 | 6 | 5 |
| 2574 | Ex | 228 | 8 | 5 |
| 2600 | NONE | 561 | 3 | 5 |
| 2711 | Gd | 800 | 7 | 4 |
plotPru2<-ggplot(data=prueba,aes(x=prueba$PoolQC,y=prueba$OverallQual))
plotPru2<-plotPru2+geom_boxplot()
plotPru2
plotPru2<-ggplot(data=prueba,aes(x=prueba$PoolQC,y=prueba$PoolArea))
plotPru2<-plotPru2+geom_boxplot()
plotPru2
Parece que existe cierta relacion entre la calidad general y el area de piscina Vamos a verlo numericamente
options(digits = 3)
prueba$razon<-(prueba$OverallQual*100)/prueba$PoolArea
#Ordenamos
prueba<-prueba%>%arrange(desc(prueba$razon))
kable(prueba)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | PoolQC | PoolArea | OverallQual | OverallCond | razon |
|---|---|---|---|---|---|
| 1975 | Ex | 144 | 10 | 5 | 6.944 |
| 2574 | Ex | 228 | 8 | 5 | 3.509 |
| 1299 | Gd | 480 | 10 | 5 | 2.083 |
| 1183 | Ex | 555 | 10 | 5 | 1.802 |
| 198 | Ex | 512 | 8 | 4 | 1.562 |
| 2504 | NONE | 444 | 6 | 5 | 1.351 |
| 1387 | Fa | 519 | 7 | 5 | 1.349 |
| 2421 | NONE | 368 | 4 | 6 | 1.087 |
| 1171 | Gd | 576 | 6 | 6 | 1.042 |
| 811 | Fa | 648 | 6 | 6 | 0.926 |
| 2711 | Gd | 800 | 7 | 4 | 0.875 |
| 1424 | Gd | 738 | 6 | 7 | 0.813 |
| 2600 | NONE | 561 | 3 | 5 | 0.535 |
Si se puede establecer una cierta relación , por lo que asignamos la calidad de la piscina asi
total[2504,73]<-'Gd'
total[2421,73]<-'Gd'
total[2600,73]<-'Fa'
No existe contradiccion entre el numero de chimeneas y la calidad
nrow(total%>%filter(Fireplaces>0 & FireplaceQu=='NONE')%>%select(Id,Fireplaces,FireplaceQu,OverallQual,OverallCond))
## [1] 0
En las areas tenemos que el area del tipo 1 + area del tipo 2 + area sin terminar = Area total
Comprobamos y buscamos incongruencias
prueba<-total%>%select(Id,TotalBsmtSF,BsmtFinSF1,BsmtFinSF2,BsmtUnfSF)
prueba[,2]<--prueba[,2]
prueba[,6]<-apply(prueba[,2:5],1,sum)
nrow(prueba%>%filter(V6>0))
## [1] 0
No existe ningun registro con el area mal
En los registros sin sotano compruebo que no exista algún campo que no corresponda
Existen 79 registros que no tienen sotano
prueba<-total%>%filter(BsmtQual=='NONE'|BsmtCond=='NONE'|BsmtExposure=='NONE'|BsmtFinType1=='NONE'|BsmtFinType2=='NONE')%>%select(Id,BsmtQual,BsmtCond,BsmtExposure,BsmtFinType1,BsmtFinType2,BsmtFullBath,BsmtHalfBath)
prueba1<-prueba%>%filter(BsmtQual!='NONE'|BsmtCond!='NONE'|BsmtExposure!='NONE'|BsmtFinType1!='NONE'|BsmtFinType2!='NONE'|BsmtFullBath>0|BsmtHalfBath>0)%>%select(Id,BsmtQual,BsmtCond,BsmtExposure,BsmtFinType1,BsmtFinType2,BsmtFullBath,BsmtHalfBath)
nrow(prueba1)
## [1] 0
Ninguno de ellos tiene incongruencias
Busco los sotanos existentes que no tienen area construida en el primer tipo
prueba<-total%>%filter(BsmtFinType1!='NONE' & BsmtFinSF1==0 )%>%select(Id,BsmtQual,BsmtCond,BsmtExposure,BsmtFinType1,BsmtFinType2,BsmtFullBath,BsmtHalfBath,TotalBsmtSF,BsmtFinSF1,BsmtFinSF2,BsmtUnfSF)
kable(table(prueba$BsmtFinType1,prueba$BsmtFinType2))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Unf | |
|---|---|
| Unf | 851 |
kable(table(prueba$BsmtFinSF1,prueba$BsmtFinSF2))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| 0 | |
|---|---|
| 0 | 851 |
nrow(prueba%>%filter(prueba$BsmtUnfSF==0))
## [1] 0
Todos los registros aparecen como Unf Inacabado. Es correcto
En los inmuebles sin garaje buscamos registros que tengan campos con contradicciones o incongruencias
prueba<-total%>%filter(GarageType=='NONE' | GarageFinish=='NONE' | GarageQual=='NONE' | GarageCond== 'NONE')%>%select(Id,GarageType,GarageYrBlt,GarageFinish,GarageQual,GarageArea,GarageCond,GarageCars)
nrow(prueba%>%filter(GarageType!='NONE' | GarageFinish!='NONE' | GarageQual!='NONE' | GarageCond!= 'NONE' | GarageYrBlt>0 | GarageCars>0 | GarageArea>0 )%>%select(Id,GarageType,GarageYrBlt,GarageFinish,GarageQual,GarageArea,GarageCond,GarageCars))
## [1] 0
En los inmuebles con garaje buscamos registros que tengan campos con contradicciones o incongruencias
prueba<-total%>%filter(GarageType!='NONE' | GarageFinish!='NONE' | GarageQual!='NONE' | GarageCond!= 'NONE' | GarageYrBlt>0 | GarageCars>0 | GarageArea>0 )%>%select(Id,GarageType,GarageYrBlt,GarageFinish,GarageQual,GarageArea,GarageCond,GarageCars)
nrow(prueba%>%filter(GarageType=='NONE' | GarageFinish=='NONE' | GarageQual=='NONE' | GarageCond== 'NONE' | GarageYrBlt==0 | GarageCars==0 | GarageArea==0)%>%select(Id,GarageType,GarageYrBlt,GarageFinish,GarageQual,GarageArea,GarageCond,GarageCars))
## [1] 0
Teniendo en cuenta que para el análisis con las variable independientes categóricas se crearan variables “dummy”, tantas como categorías-1 por cada variable, parece claro pensar que favorece reducir el numero de variables, reduciendo la complejidad.
En nuestro caso , y en mi opinión es posible realizarlo cambiando ciertas variables de categóricas a ordinales. Sobre todo en aquellas que tengan un orden que parezca lógico.
Para seguir un criterio razonable, he escogido la transformación creciente desde 0 hasta el numero de categorías dentro de cada variable, siempre desde menos a mas, o si se prefiere de peor a mejor, pero con la salvedad de que 0 solo se escoge para la categoría que significa que no existe esa variable.
Por simplificar con un ejemplo, puedo tener una variable que me habla de la calidad del acabado del garaje, dentro de las cuales tengo varias categorías que van desde una mala calidad a una muy buena. Evidentemente el orden es creciente con el máximo valor para la mejor de las categorías, pero el 0 se reserva solo si dentro de esas categorías me aparece una indicando que no tiene garaje
Estas son las variables categóricas que he seleccionado, y al lado la asignación que le doy a cada categoría de cada una de ellas
LotShape
forma general de la propiedad
| Codigo | Tipo |
|---|---|
| Reg 4 | Regular |
| IR1 3 | Slightly irregular |
| IR2 2 | Moderately Irregular |
| IR3 1 | Irregular |
LandSlope
Pendiente de la propiedad
| Codigo | Tipo |
|---|---|
| Gtl 3 | Gentle slope |
| Mod 2 | Moderate Slope |
| Sev 1 | Severe Slope |
ExterQual
calidad del material exterior
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Average/Typical |
| Fa 2 | Fair |
| Po 1 | Poor |
ExterCond
estado actual del material en el exterior
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Average/Typical |
| Fa 2 | Fair |
| Po 1 | Poor |
BsmtQual
Altura del sótano
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent (100+ inches) |
| Gd 4 | Good (90-99 inches) |
| TA 3 | Typical (80-89 inches) |
| Fa 2 | Fair (70-79 inches) |
| Po 1 | Poor (<70 inches |
| NONE 0 | No Basement |
BsmtCond
estado general del sótano
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Typical - slight dampness allowed |
| Fa 2 | Fair - dampness or some cracking or settling |
| Po 1 | Poor - Severe cracking, settling, or wetness |
| NONE 0 | No Basement |
BsmtExposure
muros de sotano a ras de suelo o de jardín
| Codigo | Tipo |
|---|---|
| Gd 4 | Good Exposure |
| Av 3 | Average Exposure (split levels or foyers typically score average or above) |
| Mn 2 | Mimimum Exposure |
| No 1 | No Exposure |
| NONE 0 | No Basement |
BsmtFinType1
Calidad del área acabada del sótano
| Codigo | Tipo |
|---|---|
| GLQ 6 | Good Living Quarters |
| ALQ 5 | Average Living Quarters |
| BLQ 4 | Below Average Living Quarters |
| Rec 3 | Average Rec Room |
| LwQ 2 | Low Quality |
| Unf 1 | Unfinshed |
| NONE 0 | No Basement |
BsmtFinType2
Calidad del segundo área terminada (si está presente)
| Codigo | Tipo |
|---|---|
| GLQ 6 | Good Living Quarters |
| ALQ 5 | Average Living Quarters |
| BLQ 4 | Below Average Living Quarters |
| Rec 3 | Average Rec Room |
| LwQ 2 | Low Quality |
| Unf 1 | Unfinshed |
| NONE 0 | No Basement |
HeatingQC
Calidad y condición de la calefacción
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Average/Typical |
| Fa 2 | Fair |
| Po 1 | Poor |
KitchenQual
calidad de la cocina
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Average/Typical |
| Fa 2 | Fair |
| Po 1 | Poor |
FireplaceQu
calidad de la chimenea
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent - Exceptional Masonry Fireplace |
| Gd 4 | Good - Masonry Fireplace in main level |
| TA 3 | Average - Prefabricated Fireplace in main living area or Masonry Fireplace in basement |
| Fa 2 | Fair - Prefabricated Fireplace in basement |
| Po 1 | Poor - Ben Franklin Stove |
| NONE 0 | No Fireplace |
GarageFinish
acabado interior del garaje
| Codigo | Tipo |
|---|---|
| Fin 3 | Finished |
| RFn 2 | Rough Finished |
| Unf 1 | Unfinished |
| NONE 0 | No Garage |
GarageQual
calidad de garaje
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Average/Typical |
| Fa 2 | Fair |
| Po 1 | Poor |
| NONE 0 | No Garage |
GarageCond
condición de garaje
| Codigo | Tipo |
|---|---|
| Ex 5 | Excellent |
| Gd 4 | Good |
| TA 3 | Average/Typical |
| Fa 2 | Fair |
| Po 1 | Poor |
| NONE 0 | No Garage |
PoolQC
calidad de la piscina
| Codigo | Tipo |
|---|---|
| Ex 4 | Excellent |
| Gd 3 | Good |
| TA 2 | Average/Typical |
| Fa 1 | Fair |
| NONE 0 | No Pool |
#Guardamos los cambios y los vuelvo a abrir para que me convierta los caracteres a factor
write.csv(total,file="Total1.csv",row.names = FALSE)
total<-read.csv("Total1.csv",sep=",",header = TRUE)
Las cambiamos
total$BsmtCond<-plyr::revalue(total$BsmtCond,c('NONE'='0','Po'='1','Fa'='2','TA'='3','Gd'='4','Ex'=5))
total$BsmtExposure<-plyr::revalue(total$BsmtExposure,c('NONE'=0,'No'=1,'Mn'=2,'Av'=3,'Gd'=4))
total$BsmtFinType1<-plyr::revalue(total$BsmtFinType1,c('NONE'=0,'Unf'=1,'LwQ'=2,'Rec'=3,'BLQ'=4,'ALQ'=5,'GLQ'=6))
total$BsmtFinType2<-plyr::revalue(total$BsmtFinType2,c('NONE'=0,'Unf'=1,'LwQ'=2,'Rec'=3,'BLQ'=4,'ALQ'=5,'GLQ'=6))
total$BsmtQual<-plyr::revalue(total$BsmtQual,c('NONE'=0,'Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$ExterCond<-plyr::revalue(total$ExterCond,c('Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$ExterQual<-plyr::revalue(total$ExterQual,c('Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$FireplaceQu<-plyr::revalue(total$FireplaceQu,c('NONE'=0,'Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$GarageCond<-plyr::revalue(total$GarageCond,c('NONE'=0,'Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$GarageFinish<-plyr::revalue(total$GarageFinish,c('NONE'=0,'Unf'=1,'RFn'=2,'Fin'=3))
total$GarageQual<-plyr::revalue(total$GarageQual,c('NONE'=0,'Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$HeatingQC<-plyr::revalue(total$HeatingQC,c('Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$KitchenQual<-plyr::revalue(total$KitchenQual,c('Po'=1,'Fa'=2,'TA'=3,'Gd'=4,'Ex'=5))
total$LandSlope<-plyr::revalue(total$LandSlope,c('Sev'=1,'Mod'=2,'Gtl'=3))
total$LotShape<-plyr::revalue(total$LotShape,c('IR3'=1,'IR2'=2,'IR1'=3,'Reg'=4))
total$PoolQC<-plyr::revalue(total$PoolQC,c('NONE'=0,'Fa'=1,'TA'=2,'Gd'=3,'Ex'=4))
total$BsmtCond<-as.numeric(levels(total$BsmtCond))[total$BsmtCond]
total$BsmtExposure<-as.numeric(levels(total$BsmtExposure))[total$BsmtExposure]
total$BsmtFinType1<-as.numeric(levels(total$BsmtFinType1))[total$BsmtFinType1]
total$BsmtFinType2<-as.numeric(levels(total$BsmtFinType2))[total$BsmtFinType2]
total$BsmtQual<-as.numeric(levels(total$BsmtQual))[total$BsmtQual]
total$ExterCond<-as.numeric(levels(total$ExterCond))[total$ExterCond]
total$ExterQual<-as.numeric(levels(total$ExterQual))[total$ExterQual]
total$FireplaceQu<-as.numeric(levels(total$FireplaceQu))[total$FireplaceQu]
total$GarageCond<-as.numeric(levels(total$GarageCond))[total$GarageCond]
total$GarageFinish<-as.numeric(levels(total$GarageFinish))[total$GarageFinish]
total$GarageQual<-as.numeric(levels(total$GarageQual))[total$GarageQual]
total$HeatingQC<-as.numeric(levels(total$HeatingQC))[total$HeatingQC]
total$KitchenQual<-as.numeric(levels(total$KitchenQual))[total$KitchenQual]
total$LandSlope<-as.numeric(levels(total$LandSlope))[total$LandSlope]
total$LotShape<-as.numeric(levels(total$LotShape))[total$LotShape]
total$PoolQC<-as.numeric(levels(total$PoolQC))[total$PoolQC]
Vamos a revisar las variables que ya teníamos como ordinales en los datos originales
Mientras que OverallQual y OverallCond no ofrecen ninguna duda, MSSubclass me parece que no esta correctamente planteada.
Puede que se usara ese código numerico para identificar mejor las distintas clases de edificación pero no tiene una relación ordinal
Se puede apreciar en este grafico con la relación que tiene con el precio
Revision de las ordinales originales
Train<-total%>%filter(is.na(SalePrice)==FALSE)
PlotClas<-ggplot()
PlotClas<-PlotClas+geom_col(data=Train,aes(x=Train$MSSubClass,y=Train$SalePrice),fill="lightblue")
PlotClas<-PlotClas+labs(x="Clases",y="Precios")
PlotClas
Cambiamos de ordinal a categorica
Cod<-c('20'='1-STORY 1946 & NEWER ALL STYLES','30'='1-STORY 1945 & OLDER','40'='1-STORY W/FINISHED ATTIC ALL AGES','45'='1-1/2 STORY - UNFINISHED ALL AGES','50'='1-1/2 STORY FINISHED ALL AGES','60'='2-STORY 1946 & NEWER','70'='2-STORY 1945 & OLDER','75'='2-1/2 STORY ALL AGES','80'='SPLIT OR MULTI-LEVEL','85'='SPLIT FOYER','90'='DUPLEX - ALL STYLES AND AGES','120'='1-STORY PUD (Planned Unit Development) - 1946 & NEWER','150'='1-1/2 STORY PUD - ALL AGES','160'='2-STORY PUD - 1946 & NEWER','180'='PUD - MULTILEVEL - INCL SPLIT LEV/FOYER','190'='2 FAMILY CONVERSION - ALL STYLES AND AGES')
total$MSSubClass<-as.factor(total$MSSubClass)
total$MSSubClass<-plyr::revalue(total$MSSubClass,Cod)
En el caso de variables cuantitativas originalmente en el dataset , vamos a revisar aquellas que no tengan justificación como numericas
#Columnas con valores numericos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
Antes de empezar voy a revisar la normalidad de las variables cuantitativas para lo cual he creado un pequeño codigo
#Preparar datos
options(digits=18)
normal<-data.frame()
for (i in 1:length(TrainNum)){
normal[i,1]<-colnames(TrainNum[i])
normal[i,2]<-shapiro.test(TrainNum[,i])[[2]]
if (normal[i,2]<0.05) {
normal[i,3]<-'NO'
}else {
normal[i,3]<-'SI'
}
}
colnames(normal)<-c('Variable','p-value')
#Numero de variables normales(SI o NO)
table(normal[,3])
##
## NO
## 53El resultado es que ninguna de las 53 variables numéricas tienen normalidad. Esto me sirve para seleccionar el método de correlacion de Spearman
Vemos las variables cuantitativas susceptibles de cambiarse a categoricas
En principio voy a revisar aquellas cuya cantidad represente algo en si misma, y en esta categoría entran todo lo referido a fechas. Repasando una por una
Vemos como se distribuye
options(digits=6)
mes1<-ggplot()
mes1<-mes1+geom_bar(data=TotalNum,aes(x=TotalNum$MoSold),fill='blue',position = 'stack')
mes1<-mes1+geom_bar(data=TrainNum,aes(x=TrainNum$MoSold),fill='red',position = 'stack')
mes1<-mes1+labs(x='MESES',y='CANTIDAD')+scale_x_continuous(breaks = pretty(TrainNum$MoSold,n=12))
mes1
En azul el total de viviendas, y por encima en rojo solo el conjunto de entrenamiento.
No parece que haya excesivas diferencias y en la mayoría de los meses se aprecia visualmente que el conjunto de entrenamiento representa la mitad del total.
Podemos apreciar que la numeración se refiere evidentemente a los meses y refleja una distribución en la venta superior en los meses de Mayo, Junio y Julio.
Veamos si eso afecta a el precio de venta en el conjunto Train
mes<-ggplot(data=TrainNum,aes(x=TrainNum$MoSold,y=TrainNum$SalePrice))
mes<-mes+stat_summary(fun.data = give.n, geom = "text", fun.y = mean)
mes<-mes+geom_bar(stat="summary",fun.y="mean",fill="royalblue")
mes<-mes+labs(x='MESES',y='PRECIO MEDIO')+scale_x_continuous(breaks = pretty(TrainNum$MoSold,n=12))
mes<-mes+scale_y_continuous(labels = scales::comma)
mes
El precio medio es parecido y no se ve relación con el mes (entre parentesis aparece la cantidad)
mes2<-ggplot()
mes2<-mes2+geom_boxplot(data=TrainNum,aes(x=TrainNum$MoSold,y=TrainNum$SalePrice,group=TrainNum$MoSold))
mes2<-mes2+labs(x='MESES',y='PRECIO ')+scale_x_continuous(breaks = pretty(TrainNum$MoSold,n=12))
mes2<-mes2+scale_y_continuous(labels = scales::comma)
mes2
Vemos correlacion
cor(x=TrainNum$MoSold,y=TrainNum$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.0694322
En mi opinión con esa correlacion tan próxima a 0 no influye para nada en el precio
Tenemos un total de cuatro años. Veamoslo gráficamente al igual que con los meses
year1<-ggplot()
year1<-year1+geom_bar(data=TotalNum,aes(x=TotalNum$YrSold),fill='blue',position = 'stack')
year1<-year1+geom_bar(data=TrainNum,aes(x=TrainNum$YrSold),fill='red',position = 'stack')
year1<-year1+labs(x='AÑOS',y='CANTIDAD')+scale_x_continuous(breaks = pretty(TrainNum$YrSold,n=5))
year1
year<-ggplot(data=TrainNum,aes(x=TrainNum$YrSold,y=TrainNum$SalePrice))
year<-year+stat_summary(fun.data = give.n, geom = "text", fun.y = mean)
year<-year+geom_bar(stat="summary",fun.y="mean",fill="royalblue")
year<-year+labs(x='AÑOS',y='PRECIO MEDIO')+scale_x_continuous(breaks = pretty(TrainNum$YrSold,n=5))
year<-year+scale_y_continuous(labels = scales::comma)
year
year2<-ggplot()
year2<-year2+geom_boxplot(data=TrainNum,aes(x=TrainNum$YrSold,y=TrainNum$SalePrice,group=TrainNum$YrSold))
year2<-year2+labs(x='AÑOS',y='PRECIO')+scale_x_continuous(breaks = pretty(TrainNum$YrSold,n=5))
year2<-year2+scale_y_continuous(labels = scales::comma)
year2
Vemos correlacion
cor(x=TrainNum$YrSold,y=TrainNum$SalePrice,method="spearman",use="na.or.complete")
## [1] -0.0298991
Tiene la particularidad de que nos puede servir para considerar la antigüedad de la vivienda y ahí puede ser relevante que sea numérico. Voy a posponerlo para mas adelante cuando veamos el año de construcción y el de remodelación
Vemos estas dos variables puesto que están muy relacionadas.
La primera no necesita explicación, en cuanto a la segunda es el año en que la vivienda ha sufrido algún tipo de remodelación.
Si no ha tenido ninguna esta se corresponde con la fecha de construcción
Vamos a ver gráficamente la posible relación con el precio de venta
built<-ggplot()
built<-built+geom_point(data=TrainNum,aes(x=TrainNum$YearBuilt,y=TrainNum$SalePrice),color='blue')
built<-built+labs(x='AÑOS',y='PRECIO',title='CONSTRUCCION')+scale_y_continuous(labels = scales::comma)
built
Vemos ahora para el año de remodelación
built1<-ggplot()
built1<-built1+geom_point(data=TrainNum,aes(x=TrainNum$YearRemodAdd,y=TrainNum$SalePrice),color='red')
built1<-built1+labs(x='AÑOS',y='PRECIO',title= 'REMODELACION')+scale_y_continuous(labels = scales::comma)
built1
Tiene la peculiaridad de que computa a partir de 1950, y en ese año tiene un numero extraordinario de casos, 178 en el Train y 361 en el total, seguramente porque se empezaría a computar ese año y todas las que tienen una antigüedad mayor se computan aqui
Parece razonable pensar a la vista de las graficas que existe algún tipo de relación con el precio de venta. Numericamente:
#Correlacion año construccion
cor(x=TrainNum$YearBuilt,y=TrainNum$SalePrice,method = "spearman",use="na.or.complete")
## [1] 0.652682
#Correlacion año remodelacion
cor(x=TrainNum$YearRemodAdd,y=TrainNum$SalePrice,method = "spearman",use="na.or.complete")
## [1] 0.571159
¿Que pasaria si distinguimos aquellas casas que han sido remodeladas , y por lo tanto su fecha de remodelacion es diferente a la de construccion, de aquellas que no lo han sido?
Prueba de remodelacion. Creamos una columna. No remodelados=0. Remodelados=1
TrainNum$Remodelado<-0
TrainNum$Remodelado[TrainNum$YearBuilt!=TrainNum$YearRemodAdd]<-1
#Dividimos el dataset
T1<-TrainNum%>%filter(Remodelado==1)
T0<-TrainNum%>%filter(Remodelado==0)
#Calculamos correlacion para remodelados
#Correlacion año construccion
cor(x=T1$YearBuilt,y=T1$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.643186
#Correlacion año remodelacion
cor(x=T1$YearRemodAdd,y=T1$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.478056
#No remodelados
cor(x=T0$YearBuilt,y=T0$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.680097
Esta claro que importa el año de construccion, importa el año de remodelacion, importa si estan o no remodeladas en cuanto afecta a su antigüedad y además tenemos unos valores extraños en 1950 que debemos corregir.
Voy a considerar que ninguna de esas viviendas han sido remodeladas por lo que aplicare a esa variable, la del año de construcción
Aplico a la remodelacion de los de 1950 el año de construccion
total$YearRemodAdd[total$YearRemodAdd<1951]<-total$YearBuilt[total$YearRemodAdd<1951]
#Recargamos los datos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
#Vuelvo a comprobar correlacion
TrainNum$Remodelado<-0
TrainNum$Remodelado[TrainNum$YearBuilt!=TrainNum$YearRemodAdd]<-1
#Dividimos el dataset
T1<-TrainNum%>%filter(Remodelado==1)
T0<-TrainNum%>%filter(Remodelado==0)
#Calculamos correlacion para remodelados
#Correlacion año construccion
cor(x=T1$YearBuilt,y=T1$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.613344
#Correlacion año remodelacion
cor(x=T1$YearRemodAdd,y=T1$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.229517
#No remodelados
cor(x=T0$YearBuilt,y=T0$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.708576
built3<-ggplot()
built3<-built3+geom_point(data=TrainNum,aes(x=TrainNum$YearBuilt,y=TrainNum$SalePrice,color=Remodelado))
built3<-built3+facet_grid(Remodelado~.,labeller = label_both)+theme(legend.position = 'none')
built3<-built3+labs(x='AÑOS',y='PRECIO',title='AÑO CONSTRUCCION VIVIENDAS')+scale_y_continuous(labels = scales::comma)
built3
Vamos a afinar un poco mas calculando la antigüedad respecto al año de venta. Creamos una columna nueva:
Calculo antiguedad completa
total$Antiguedad<-total$YrSold-total$YearBuilt
#Recargamos los datos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
#Buscamos errores
kable(TotalNum%>%filter(Antiguedad<0)%>%select(Id,YearBuilt,YrSold))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | YearBuilt | YrSold |
|---|---|---|
| 2550 | 2008 | 2007 |
Existe un registro con año venta anterior al de la construccion. Lo igualo
total[2550,78]<-2008
#Recargamos los datos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
Busco errores también en el año de remodelación
Revision de incongruencia de datos con YearRemodAdd
kable(TotalNum%>%filter((TotalNum$YrSold-TotalNum$YearRemodAdd)<0)%>%select(Id,YrSold,YearBuilt,YearRemodAdd))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | YrSold | YearBuilt | YearRemodAdd |
|---|---|---|---|
| 524 | 2007 | 2007 | 2008 |
| 2296 | 2007 | 2007 | 2008 |
| 2550 | 2008 | 2008 | 2009 |
Corrijo los valores al año de venta
total[524,21]<-2007
total[2296,21]<-2007
total[2550,21]<-2008
Mas incongruencias
kable(TotalNum%>%filter((TotalNum$YearBuilt-TotalNum$YearRemodAdd)>0)%>%select(Id,YrSold,YearBuilt,YearRemodAdd))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | YrSold | YearBuilt | YearRemodAdd |
|---|---|---|---|
| 1877 | 2009 | 2002 | 2001 |
Corrijo los valores al año de construccion
total[1877,21]<-2002
Volvemos a calcular y actualizar
total$Antiguedad<-total$YrSold-total$YearBuilt
#Recargamos los datos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
#Vuelvo a comprobar correlacion
TrainNum$Remodelado<-0
TrainNum$Remodelado[TrainNum$YearBuilt!=TrainNum$YearRemodAdd]<-1
#Dividimos el dataset
T1<-TrainNum%>%filter(Remodelado==1)
T0<-TrainNum%>%filter(Remodelado==0)
#Calculamos correlacion para remodelados
cor(x=T1$Antiguedad,y=T1$SalePrice,method="spearman",use="na.or.complete")
## [1] -0.612723
#No remodelados
cor(x=T0$Antiguedad,y=T0$SalePrice,method="spearman",use="na.or.complete")
## [1] -0.706995
built4<-ggplot()
built4<-built4+geom_point(data=TrainNum,aes(x=TrainNum$Antiguedad,y=TrainNum$SalePrice,color=Remodelado))
built4<-built4+facet_grid(Remodelado~.,labeller = label_both)+theme(legend.position = 'none')
built4<-built4+labs(x='AÑOS',y='PRECIO',title='ANTIGUEDAD VIVIENDAS')+scale_y_continuous(labels = scales::comma)
built4
Los valores son parecidos pero al calcular sobre el numero de años se invierte el signo
En conclusión, la antigüedad de la vivienda tiene una relación fuerte con el precio de venta, y además el hecho de ser una vivienda remodelada o no tambien es importante.
Le afecta menos cuando se ha realizado dicha remodelación.
Por lo cual calculamos la antigüedad (ya realizado), calculamos si hay o no remodelación
#Conclusiones
total$Remodelado<-0
total$Remodelado[total$YearBuilt!=total$YearRemodAdd]<-1
#Recargamos los datos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
Si calculamos la correlacion de la antiguedad respecto al precio tenemos un valor -0.65012.
Hemos visto que los remodelados tienen -0.612723 y los no remodelados -0.706995 lo que significa que están penalizados por el calculo conjunto.
Podriamos pensar que si tomamos la antigüedad como la diferencia entre el año de venta y el de remodelación(teniendo en cuenta que para las viviendas no remodeladas este es igual que el de construcción) obtendríamos una variable mas adecuada, pero es al contrario , el valor de la correlacion es -0.575787.
Hay que encontrar una manera de penalizar a las viviendas remodeladas en su antigüedad
Mi propuesta es penalizar a las viviendas que han sido remodeladas aumentando su antigüedad de manera artificial.
Proporcionalmente al tiempo que se ha tardado en remodelar. ¿Cuánto?. La decima porcentual que tienen de diferencia las correlaciones.
#Penalizacion
TotalNum.remo<-TotalNum%>%filter(Remodelado==1)
summary(TotalNum.remo$YearRemodAdd-TotalNum.remo$YearBuilt)## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 1.0 1.0 20.0 29.9 52.0 127.0
Creo una columna donde pongo este calculo
Como la antiguedad la tenemos en enteros y para ser justo con la penalizacion voy a normalizar las variables
Luego le aplicare un 10% de la antigüedad de la remodelación a la antigüedad de la vivienda
total$Penaliza<-total$YearRemodAdd-total$YearBuilt
#Normalizo
total$Antiguedad<-normalize(total$Antiguedad)
total$Penaliza<-normalize(total$Penaliza)
#Penalizo
total$Antiguedad<-total$Antiguedad+total$Penaliza*0.1
#Borro las variables auxiliares Remodelado y Penaliza
total$Remodelado<-NULL
total$Penaliza<-NULL
#Recargamos los datos
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
Eliminamos los valores igual a 0, o sea que no tienen garaje. Ya comprobamos anteriormente la congruencia de los registros
Vemos gráficamente
GarageTOTAno<-TotalNum%>%filter(GarageYrBlt!=0)
garage<-ggplot(data=GarageTOTAno,aes(x=GarageTOTAno$GarageYrBlt))
garage<-garage+geom_histogram(fill='blue')
garage<-garage+labs(x='AÑOS',y='PRECIO',title='AÑO CONSTRUCCION GARAGE')+scale_y_continuous(labels = scales::comma)
garage
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Tenemos un outlier. Corresponde al registro 2593. Vamos a ver los datos pertinentes
kable(total%>%filter(Id==2593)%>%select(Id,GarageType,GarageYrBlt,GarageFinish,GarageQual,GarageArea,GarageCond,GarageCars,YearBuilt,YearRemodAdd,YrSold))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | GarageType | GarageYrBlt | GarageFinish | GarageQual | GarageArea | GarageCond | GarageCars | YearBuilt | YearRemodAdd | YrSold |
|---|---|---|---|---|---|---|---|---|---|---|
| 2593 | Attchd | 2207 | 2 | 3 | 502 | 3 | 2 | 2006 | 2007 | 2007 |
Podemos inferir que el año real de construcción del garaje es 2007. Modificamos
total[2593,60]<-2007
Recalculamos y volvemos a observar
#Recalcular
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
#Visualizacion total
GarageTOTAno<-TotalNum%>%filter(GarageYrBlt!=0)
garage<-ggplot(data=GarageTOTAno,aes(x=GarageTOTAno$GarageYrBlt))
garage<-garage+geom_histogram(fill='blue')
garage<-garage+labs(x='AÑOS',y='PRECIO',title='AÑO CONSTRUCCION GARAGE')+scale_y_continuous(labels = scales::comma)
garage
## `stat_bin()` using `bins = 30`. Pick better value with `binwidth`.
Verifico que el año de construcción del Garage sea posterior al de la casa
GarageTOTAno$dif<-GarageTOTAno$GarageYrBlt-GarageTOTAno$YearBuilt
kable(GarageTOTAno%>%filter(dif<0)%>%select(Id,YearBuilt,GarageYrBlt))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | YearBuilt | GarageYrBlt |
|---|---|---|
| 30 | 1927 | 1920 |
| 94 | 1910 | 1900 |
| 325 | 1967 | 1961 |
| 601 | 2005 | 2003 |
| 737 | 1950 | 1949 |
| 1104 | 1959 | 1954 |
| 1377 | 1930 | 1925 |
| 1415 | 1923 | 1922 |
| 1419 | 1963 | 1962 |
| 1522 | 1959 | 1956 |
| 1577 | 2010 | 2009 |
| 1806 | 1935 | 1920 |
| 1841 | 1978 | 1960 |
| 1896 | 1941 | 1940 |
| 1898 | 1935 | 1926 |
| 2123 | 1945 | 1925 |
| 2264 | 2006 | 2005 |
| 2510 | 2006 | 2005 |
Hay 18 registros que tienen el año de construccion del garage anterior al de la vivienda. Entiendo que se debe a errores tipográficos, como confundir un 4 por un 9 o diferencias pequeñas de tiempo que hacen variar en un año
Ponemos el año como el de la vivienda
total$GarageYrBlt[(total$GarageYrBlt<total$YearBuilt)&(total$GarageYrBlt!=0)]<-total$YearBuilt[(total$GarageYrBlt<total$YearBuilt)&(total$GarageYrBlt!=0)]
#Recalculo
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
Veamos la relación con el precio
#Visualizar train. Eliminamos los que no tienen garaje
GarageAno<-TrainNum%>%filter(GarageYrBlt!=0)
garage1<-ggplot()
garage1<-garage1+geom_point(data=GarageAno,aes(x=GarageAno$GarageYrBlt,y=GarageAno$SalePrice))
garage1<-garage1+labs(x='AÑOS',y='PRECIO',title='AÑO CONSTRUCCION GARAGE')+scale_y_continuous(labels = scales::comma)
garage1
Parece existir una relación. Numericamente
cor(x=GarageAno$GarageYrBlt,y=GarageAno$SalePrice,method="spearman",use="na.or.complete")
## [1] 0.594246
Hay que tener en cuenta que no he incluido los registros que no tienen garaje.
Si se les incluye, curiosamente la correlacion aumenta.
De todas formas es interesante realizar como con la variable anterior, calcular la antigüedad
#Calculo antiguedad Garaje
total$AntGarage<-total$YrSold-total$GarageYrBlt
#Recalculo
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
#Correlacion
cor(x=TrainNum$AntGarage,y=TrainNum$SalePrice,method="spearman",use="na.or.complete")
## [1] -0.63301
garage2<-ggplot()
garage2<-garage2+geom_point(data=TrainNum,aes(x=TrainNum$AntGarage,y=TrainNum$SalePrice))
garage2<-garage2+labs(x='AÑOS',y='PRECIO',title='ANTIGUEDAD CONSTRUCCION GARAGE')+scale_y_continuous(labels = scales::comma)
garage2
En conclusion para las variables YearBuilt, YearRemodAdd, MoSold, YrSold y GarageYrBlt nos quedamos con Antigüedad y AntGarage como variables importantes para el precio de venta
Vemos a continuacion el resto de variables cuantitativas y relación entre ellas para poder ver si reducimos su numero.
Voy a crear una matriz de correlaciones entre estas variables sin contar en principio con el precio.
Para saber si existe una dependencia entre algunas de ellas que nos pueda servir.
Para eso uso el paquete corrplot
Primero la correlacion de las variables entre si, sin contar con el precio ni las variables ya tratadas
TotalNum.noprice<-TotalNum%>%select(-Id,-SalePrice,-YearBuilt,-YearRemodAdd,-MoSold,-YrSold,-GarageYrBlt )
#Matriz correlaciones
CorrNum<-cor(TotalNum.noprice,method = 'spearman')
#Valores absolutos
CorrNum.abs<-as.data.frame(abs(CorrNum))
#Pongo a 0 los 1 para encontrar el maximo
CorrNum.abs[which(CorrNum.abs==1,arr.ind = TRUE)]<-0
#Busco el valor maximo de correlacion en cada variable ahora
CorrNum.inf<-apply(CorrNum.abs,2,max)
#Elimino las filas y columnas con correlacion baja
CorrNum.max<-CorrNum.abs[-(which(CorrNum.inf<0.5)),-(which(CorrNum.inf<0.5))]
#Pongo a 0 los valores inferiores a 0.5
CorrNum.max[which(CorrNum.max<0.5,arr.ind = TRUE)]<-0
CorrNum.max<-as.matrix(CorrNum.max)
corrplot(CorrNum.max,order = 'hclust',hclust.method = 'ward.D2',sig.level = 0.5,tl.col = 'black',tl.cex = 0.8,tl.srt = 45,addrect = 14,diag = FALSE)
Se ve claramente dependencia en ciertos grupos de variables.
Antes de seguir vamos a ver la correlacion de las variable significativas (superior a 0.5 en términos absolutos) respecto al Precio
#CORRELACION CON PRECIO
TrainNum.price<-TrainNum%>%select(-Id,-YearBuilt,-YearRemodAdd,-MoSold,-YrSold,-GarageYrBlt )
#Matriz correlaciones
CorrPri<-cor(TrainNum.price,method = 'spearman')
CorrPri.abs<-as.data.frame(CorrPri)
#Pongo a 0 los 1 para encontrar el maximo
CorrPri.abs[which(CorrPri.abs==1,arr.ind = TRUE)]<-0
#Busco el valor maximo de correlacion en cada variable ahora
CorrPri.inf<-apply(CorrPri.abs,2,max)
#Busco el valor minimo de correlacion en cada variable ahora
CorrPri.sup<-apply(CorrPri.abs,2,min)
#Elimino las filas y columnas con correlacion baja
CorrPri.max<-CorrPri.abs[-(which(CorrPri.inf<0.5 & CorrPri.sup>-0.5)),-(which(CorrPri.inf<0.5 & CorrPri.sup>-0.5))]
#Pongo a 0 los valores inferiores a 0.5 y superiores a -0.5
CorrPri.max[which((CorrPri.max<0.5 & CorrPri.max>-0.5),arr.ind = TRUE)]<-0
CorrPri.max<-as.matrix(CorrPri.max)
#Reordenamos por FPC
Orden.fpc<-corrMatOrder(CorrPri.max,order='FPC') #Primer Componente principal
CorrNum.fpc<-CorrPri.max[Orden.fpc,Orden.fpc]
#Grafico
corrplot(CorrNum.fpc,type='lower',tl.col = 'black',tl.cex = .8,tl.srt = 30)
En el grafico en la fila inferior tenemos SalePrice.
En rojo las variables con correlacion negativa :
AntGarage Antigüedad
En azul las variables predictoras con correlacion positiva:
GarageArea GarageCars
Fireplaces FireplaceQu
X1stFlrSF TotalBsmtSF
TotRmsAbvGrd GrLivArea FullBath
GarageFinish
KitchenQual
BsmtQual
ExterQual
OverallQual
Las variables que pongo juntas tienen una correlacion fuerte (ver primer grafico ) entre ellas y cierta explicacion lógica. Las vere a continuación por si se puede reducir el numero de variables predictoras
Es evidente que tiene una gran correlacion porque en cierta medida su valor crece de manera proporcionada.
Si una vivienda tiene un garaje, la antigüedad del garaje crece de igual manera que la antigüedad de la vivienda y suelen ser iguales salvo que el garaje se haya construido después.
De todas formas no soy partidario de unirlas de alguna forma porque la variable AntGarage tiene la peculiaridad de aquellas viviendas sin garaje que hay que mantener
Solo voy a normalizar la varable AntGarage, puesto que Antigüedad ya lo estaba
total$AntGarage<-normalize(total$AntGarage)
#Recalculo
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
A pesar de que tienen relación con otras variables la mas importante es entre ellos, y puede parecer lógico puesto que el numero de coches que pueda entrar en un garaje depende directamente del espacio que este tenga
Primero normalizo las variables según función
TotalNum$GarageArea<-normalize(TotalNum$GarageArea)
TotalNum$GarageCars<-normalize(TotalNum$GarageCars)
cor(x=TotalNum$GarageArea,y=TotalNum$GarageCars,method = 'spearman')
## [1] 0.864929
La relacion es positiva. Ambas tienen una correlacion positiva y parecida con respecto al precio
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
cor(x=TrainNum$GarageArea,y=TrainNum$SalePrice,method = 'spearman')
## [1] 0.649379
cor(x=TrainNum$GarageCars,y=TrainNum$SalePrice,method = 'spearman')
## [1] 0.690711
La opcion que opto es multiplicar ambas variables puesto que GarageCars es discreta y GarageArea es continua.
La nueva variable se convierte en continua, mantiene la normalización y el valor 0 para los que no tienen garaje
TrainNum$Garage2<-TrainNum$GarageArea*TrainNum$GarageCars
cor(x=TrainNum$Garage2,y=TrainNum$SalePrice,method = 'spearman')
## [1] 0.668591
Es una correlacion media de las otras dos
total$GarageTotal<-normalize(total$GarageArea)*normalize(total$GarageCars)
#Recalculo
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
Fireplaces es el numero de chimeneas
FireplacesQu es la calidad según vimos cuando se paso de categorica a ordinal
La correlacion positiva entre ellas nos indica que a medida que el numero de chimeneas aumenta también aumenta la calidad
cor(x=total$Fireplaces,y=total$FireplaceQu,method = 'kendall')
## [1] 0.820617
Ademas es una relacion fuerte. v Vemos un grafico
chim<-ggplot(data=TotalNum,aes(x=TotalNum$Fireplaces, y=TotalNum$FireplaceQu))
chim<-chim+geom_count()+labs(x="NUMERO",y="CALIDAD")
chim
Con respecto al precio
cor(x=TrainNum$FireplaceQu,y=TrainNum$SalePrice,method='spearman')
## [1] 0.537602
cor(x=TrainNum$Fireplaces,y=TrainNum$SalePrice,method='spearman')
## [1] 0.519247
La correlacion con el precio no es muy alta y ademas la correlacion entre ellas es altisima, por lo que me quedo con una y descarto la otra
Me quedo con FireplaceQu . La normalizo
total$FireplaceQu<-normalize(total$FireplaceQu)
#Recalculo
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
1stFlrSF corresponde al área del primer piso.
TotalBsmtSF es el área del sotano
La correlacion entre ellos es bastante alta
cor(x=total$X1stFlrSF,y=total$TotalBsmtSF,method='spearman')
## [1] 0.828737
Se presupone que las viviendas que tienen sotano , por lo general el área en planta del sotano es igual que el de la primera planta.
La diferencia por lo general esta en que todas las viviendas tienen primera planta, pero no todas tienen sotano
summary(total$X1stFlrSF)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 334 876 1082 1160 1388 5095
summary(total$TotalBsmtSF)
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## 0 793 989 1051 1302 6110
Vemos un grafico esclarecedor
pru<-ggplot()
pru<-pru+geom_point(data=TotalNum,aes(x=TotalNum$X1stFlrSF,y=TotalNum$TotalBsmtSF))
pru<-pru+scale_x_continuous(limits=c(0,6150))+scale_y_continuous(limits=c(0,6150))
pru<-pru+labs(x='AREA PRIMER PISO',y='AREA SOTANO')
pru
Se aprecian dos líneas claramente, una siguiendo el eje de abscisas en o que son las viviendas sin sotano y la otra línea de inclinación 45º que son las viviendas que tienen el mismo área de vivienda que de sotano.
Hay que destacar que hay unas cuantas viviendas que tienen mas área de sotano que de primer piso
Vemos su correlacion con el precio
cor(x=TrainNum$X1stFlrSF,y=TrainNum$SalePrice,method='spearman')
## [1] 0.575408
cor(x=TrainNum$TotalBsmtSF,y=TrainNum$SalePrice,method='spearman')
## [1] 0.602725
No parece que haya una correlacion muy alta . Lo vemos gráficamente
pru<-ggplot()
pru<-pru+geom_point(data=TrainNum,aes(x=TrainNum$X1stFlrSF,y=TrainNum$SalePrice),color='red')
pru<-pru+geom_point(data=TrainNum,aes(x=TrainNum$TotalBsmtSF,y=TrainNum$SalePrice),color='blue')
pru<-pru+labs(x='AREAS ',y='Precio')+scale_y_continuous(labels = scales::comma)
pru
Tenemos dos outliers en la esquina inferior derecha. Les busco
kable(TrainNum%>%filter(X1stFlrSF>3000 & SalePrice<200000)%>%select(Id,X1stFlrSF,TotalBsmtSF,SalePrice))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | X1stFlrSF | TotalBsmtSF | SalePrice |
|---|---|---|---|
| 524 | 3138 | 3138 | 184750 |
| 1299 | 4692 | 6110 | 160000 |
Excluyo estos valores para ver si mejora
TrainNum.piso<-TrainNum%>%filter(Id!=524)%>%filter(Id!=1299)
pru<-ggplot()
pru<-pru+geom_point(data=TrainNum.piso,aes(x=TrainNum.piso$X1stFlrSF,y=TrainNum.piso$SalePrice),color='red')
pru<-pru+geom_point(data=TrainNum.piso,aes(x=TrainNum.piso$TotalBsmtSF,y=TrainNum.piso$SalePrice),color='blue')
pru<-pru+labs(x='AREAS ',y='Precio')+scale_y_continuous(labels = scales::comma)
pru
El grafico parece que ha mejorado. Veamos numéricamente
cor(x=TrainNum.piso$X1stFlrSF,y=TrainNum.piso$SalePrice,method='spearman')
## [1] 0.576221
cor(x=TrainNum.piso$TotalBsmtSF,y=TrainNum.piso$SalePrice,method='spearman')
## [1] 0.603604
Sí hay mejoria pero no parece significativa.
En principio no descarto estos registros por si afectan a otras variables
Voy a separar en la variable de área de primera planta a las viviendas que tienen sotano y las que no
#Separo las viviendas por el sotano
TrainNum.sot<-TrainNum%>%filter(TotalBsmtSF==0)%>%select(Id,X1stFlrSF,TotalBsmtSF,SalePrice)
TrainNum.piso<-TrainNum%>%filter(TotalBsmtSF>0)%>%select(Id,X1stFlrSF,TotalBsmtSF,SalePrice)
Vemos graficamente
pru<-ggplot()
pru<-pru+geom_point(data=TrainNum.piso,aes(x=TrainNum.piso$X1stFlrSF,y=TrainNum.piso$SalePrice),color='blue',alpha=0.1)
pru<-pru+geom_point(data=TrainNum.sot,aes(x=TrainNum.sot$X1stFlrSF,y=TrainNum.sot$SalePrice),color='red',alpha=0.3)
pru<-pru+labs(x='AREAS ',y='Precio')+scale_y_continuous(labels = scales::comma)
pru
Se aprecia que las vivendas sin sotano (puntos rojos) están penalizadas en el precio, están en la parte baja de la nube.
En mi opinión se debería combinar ambas variables pero que penalizen a las viviendas sin sotano, parecido a lo que sucedia a la penalizacion en la antigüedad.
Para eso voy a sumar el área del sotano y el de la primera planta
La mayoría de las viviendas verán casi doblada su superficie, pero las viviendas sin sotano se quedan como están
TrainNum$AreaPiso<-TrainNum$X1stFlrSF+TrainNum$TotalBsmtSF
Vemos graficamente
pru<-ggplot()
pru<-pru+geom_point(data=TrainNum,aes(x=TrainNum$AreaPiso,y=TrainNum$SalePrice),color='blue',alpha=0.2)
pru<-pru+labs(x='AREAS ',y='Precio')+scale_y_continuous(labels = scales::comma)
pru
La correlacion mejora
cor(x=TrainNum$AreaPiso,y=TrainNum$SalePrice,method='spearman')
## [1] 0.623865
La distribución parece bastante parecida.
Dejamos asi la nueva variable y la normalizamos
total$AreaPiso<-normalize(total$X1stFlrSF+total$TotalBsmtSF)
#Recalculo
NNum<-which(sapply(total,is.numeric))
TotalNum<-total[,NNum]
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
Estas variables corresponde a
GrLivArea pies cuadrados del área habitable sobre el nivel del suelo FullBath baños completos por encima del suelo TotRmsAbvGrd Total de habitaciones por encima del suelo (no incluye baños)
Parece evidente una relación lógica entre la primera variable y las otras dos
kable(cor(total%>%select(GrLivArea,FullBath,TotRmsAbvGrd),method='spearman'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| GrLivArea | FullBath | TotRmsAbvGrd | |
|---|---|---|---|
| GrLivArea | 1.000000 | 0.662752 | 0.808775 |
| FullBath | 0.662752 | 1.000000 | 0.536076 |
| TotRmsAbvGrd | 0.808775 | 0.536076 | 1.000000 |
Graficamente
pru<-ggplot()
pru<-pru+geom_point(data=TotalNum,aes(x=TotalNum$TotRmsAbvGrd,y=TotalNum$GrLivArea),color='blue',alpha=0.1)
pru<-pru+geom_point(data=TotalNum,aes(x=TotalNum$FullBath,y=TotalNum$GrLivArea),color='red',alpha=0.3)
pru<-pru+labs(x='Estancias ',y='Area')+scale_y_continuous(labels = scales::comma)
pru
Tenemos dos outliers que con un area habitable superior a 5000 y con 12 y 15 habitaciones solo tiene 2 baños
TotalNum.sala<-TotalNum
kable(TotalNum%>%filter(FullBath==2 & GrLivArea>5000)%>%select(Id,GrLivArea,FullBath,TotRmsAbvGrd))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | GrLivArea | FullBath | TotRmsAbvGrd |
|---|---|---|---|
| 1299 | 5642 | 2 | 12 |
| 2550 | 5095 | 2 | 15 |
Les descarto y compruebo como queda la matriz de correlacion
TotalNum.sala<-TotalNum.sala%>%filter(Id!=1299)%>%filter(Id!=2550)
kable(cor(TotalNum.sala%>%select(GrLivArea,FullBath,TotRmsAbvGrd),method='spearman'))| GrLivArea | FullBath | TotRmsAbvGrd | |
|---|---|---|---|
| GrLivArea | 1.000000 | 0.662584 | 0.808373 |
| FullBath | 0.662584 | 1.000000 | 0.535749 |
| TotRmsAbvGrd | 0.808373 | 0.535749 | 1.000000 |
Parece que incluso ha empeorado
Pero voy a verlo teniendo en cuenta el precio
TrainNum.sala<-TotalNum.sala%>%filter(is.na(SalePrice)==FALSE)
#Correlacion con outliers
kable(cor(TrainNum%>%select(GrLivArea,FullBath,TotRmsAbvGrd,SalePrice),method='spearman'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| GrLivArea | FullBath | TotRmsAbvGrd | SalePrice | |
|---|---|---|---|---|
| GrLivArea | 1.000000 | 0.658419 | 0.827874 | 0.731310 |
| FullBath | 0.658419 | 1.000000 | 0.558665 | 0.635957 |
| TotRmsAbvGrd | 0.827874 | 0.558665 | 1.000000 | 0.532586 |
| SalePrice | 0.731310 | 0.635957 | 0.532586 | 1.000000 |
#Correlacion sin outliers
kable(cor(TrainNum.sala%>%select(GrLivArea,FullBath,TotRmsAbvGrd,SalePrice),method='spearman'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| GrLivArea | FullBath | TotRmsAbvGrd | SalePrice | |
|---|---|---|---|---|
| GrLivArea | 1.000000 | 0.658246 | 0.827514 | 0.732112 |
| FullBath | 0.658246 | 1.000000 | 0.558364 | 0.636043 |
| TotRmsAbvGrd | 0.827514 | 0.558364 | 1.000000 | 0.533215 |
| SalePrice | 0.732112 | 0.636043 | 0.533215 | 1.000000 |
Se puede observar como al quitar los outliers la correlacion entre las variables que estudiamos empeoran pero mejoran todas con respecto al precio.
Lo dejamos en recordatorio como los otros que hemos visto para más adelante
Podemos pensar que si consideramos los baños como una estancia mas podemos unirlo en una sola variable
Pregunta: ¿Qué significa que haya viviendas que no tengan baño?
#Si se suman los baños y las estancias
#¿No tienen baño?
kable(TotalNum%>%filter(FullBath==0)%>%select(Id,HalfBath,BsmtFullBath,BsmtHalfBath))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | HalfBath | BsmtFullBath | BsmtHalfBath |
|---|---|---|---|
| 54 | 1 | 2 | 0 |
| 189 | 2 | 2 | 0 |
| 376 | 1 | 1 | 0 |
| 598 | 2 | 0 | 2 |
| 635 | 0 | 2 | 0 |
| 917 | 0 | 1 | 0 |
| 1164 | 2 | 2 | 0 |
| 1214 | 0 | 1 | 1 |
| 1271 | 1 | 2 | 0 |
| 1860 | 2 | 2 | 0 |
| 2514 | 1 | 2 | 0 |
| 2601 | 1 | 2 | 0 |
Respuesta: Que tienen medios baños o baños en el sotano
Esta es la grafica de la relación entre los baños y el precio
pru<-ggplot()
pru<-pru+geom_boxplot(data=TotalNum,aes(x=TotalNum$FullBath,y=TotalNum$SalePrice,group=TotalNum$FullBath),color='red')
pru<-pru+labs(x='Baños ',y='Precio')+scale_y_continuous(labels = scales::comma)
pru
## Warning: Removed 1459 rows containing non-finite values (stat_boxplot).
Las vivendas sin baño están penalizadas en el precio aunque no demasiado
Si sumamos los baños como una estancia mas
#Sumamos los baños
TotalNum$estancias<-TotalNum$FullBath+TotalNum$TotRmsAbvGrd
kable(cor(TotalNum%>% select(GrLivArea,FullBath,TotRmsAbvGrd,estancias),method='spearman'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| GrLivArea | FullBath | TotRmsAbvGrd | estancias | |
|---|---|---|---|---|
| GrLivArea | 1.000000 | 0.662752 | 0.808775 | 0.852309 |
| FullBath | 0.662752 | 1.000000 | 0.536076 | 0.743707 |
| TotRmsAbvGrd | 0.808775 | 0.536076 | 1.000000 | 0.960388 |
| estancias | 0.852309 | 0.743707 | 0.960388 | 1.000000 |
Evidentemente la correlacion con las variables que la componen tiene que ser alta, pero con el area habitable mejora bastante la correlacion individual mejor que tenia antes
Voy a sumarle también los medios baños pero reducido a la mitad en su valor
#Sumamos los medios baños
TotalNum$estancias2<-TotalNum$FullBath+TotalNum$TotRmsAbvGrd+(TotalNum$HalfBath/2)
kable(cor(TotalNum%>% select(GrLivArea,FullBath,TotRmsAbvGrd,estancias,estancias2),method='spearman'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| GrLivArea | FullBath | TotRmsAbvGrd | estancias | estancias2 | |
|---|---|---|---|---|---|
| GrLivArea | 1.000000 | 0.662752 | 0.808775 | 0.852309 | 0.865065 |
| FullBath | 0.662752 | 1.000000 | 0.536076 | 0.743707 | 0.723524 |
| TotRmsAbvGrd | 0.808775 | 0.536076 | 1.000000 | 0.960388 | 0.958442 |
| estancias | 0.852309 | 0.743707 | 0.960388 | 1.000000 | 0.991040 |
| estancias2 | 0.865065 | 0.723524 | 0.958442 | 0.991040 | 1.000000 |
Aunque empeora la correlacion con las otras variables, mejora con el area habitable que es con la que voy a combinarla y normalizarlas
#Combinar con area habitable y normalizar
TotalNum$Habitat<-normalize(TotalNum$estancias2*TotalNum$GrLivArea)
#Comparamos con precio
TrainNum<-TotalNum%>%filter(is.na(SalePrice)==FALSE)
kable(cor(TrainNum%>% select(GrLivArea,FullBath,TotRmsAbvGrd,estancias,Habitat,SalePrice),method='spearman'))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| GrLivArea | FullBath | TotRmsAbvGrd | estancias | Habitat | SalePrice | |
|---|---|---|---|---|---|---|
| GrLivArea | 1.000000 | 0.658419 | 0.827874 | 0.860974 | 0.974100 | 0.731310 |
| FullBath | 0.658419 | 1.000000 | 0.558665 | 0.751499 | 0.714628 | 0.635957 |
| TotRmsAbvGrd | 0.827874 | 0.558665 | 1.000000 | 0.964700 | 0.916140 | 0.532586 |
| estancias | 0.860974 | 0.751499 | 0.964700 | 1.000000 | 0.948747 | 0.618233 |
| Habitat | 0.974100 | 0.714628 | 0.916140 | 0.948747 | 1.000000 | 0.704260 |
| SalePrice | 0.731310 | 0.635957 | 0.532586 | 0.618233 | 0.704260 | 1.000000 |
La nueva variable esta mucho mas correlacionada con las tres variables originales y además se acerca bastante a la variable original de mayor correlacion con el precio
Creamos en dataset conjunto y normalizamos
#Crear variable y normalizar
total$Habitat<-normalize((total$FullBath+total$TotRmsAbvGrd+(total$HalfBath/2))*total$GrLivArea)
GarageFinish acabado interior del garaje
KitchenQual calidad de la cocina
BsmtQual Altura del sótano
ExterQual calidad del material exterior
OverallQual material general y calidad de acabado
Son todas variables ordinales que indican distintos acabados/calidades de la vivienda
Es razonable pensar que junto con otras variables que no aparecen por no estar tan relacionadas, mantengan una correspondencia al nivel general de calidad de la vivienda y este está asociado al precio de manera importante.
En mi opinión no tiene justificación lógica el combinar varias de estas variables puesto que no tienen una relación causal a pesar de que tengan una correlacion importante
Las normalizamos
total$GarageFinish<-normalize(total$GarageFinish)
total$KitchenQual<-normalize(total$KitchenQual)
total$BsmtQual<-normalize(total$BsmtQual)
total$ExterQual<-normalize(total$ExterQual)
total$OverallQual<-normalize(total$OverallQual)
De todas las variables cuantitativas nos quedamos con las siguientes:
Antiguedad AntGaraje GarageTotal FirePlaceQu AreaPiso Habitat GarageFinish KitchenQual BsmtQual ExterQual OverallQual
De un total de 51 variables numéricas del dataset (excluyendo la identificación Id y el precio de venta) hemos reducido las variables predictoras a 11
En el caso del estudio de las variables categóricas, tenemos que partir de un enfoque diferente
Como estamos hablando de variables categóricas no podemos en principio calcular un valor directo como usábamos el de la correlacion en las variables continuas.
Pero si podemos usar el coeficiente de determinación o bondad del ajuste que en los casos de regresion lineal simple es el cuadrado de la correlacion de Pearson.
La manera simple mas directa es calculando variable por variable
#Columnas con valores categoricos
NFact<-which(sapply(total,is.factor))
TotalFact<-total[,NFact]
#Añado variables numericas Id y SalePrice
TotalFact$Id<-total$Id
TotalFact$SalePrice<-total$SalePrice
TrainFact<-TotalFact%>%filter(is.na(SalePrice)==FALSE)
#Calculo directo
summary(lm(TrainFact$SalePrice ~ TrainFact$Foundation, data = TrainFact))
##
## Call:
## lm(formula = TrainFact$SalePrice ~ TrainFact$Foundation, data = TrainFact)
##
## Residuals:
## Min 1Q Median 3Q Max
## -147230 -40230 -11118 24724 529770
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 132291 5679 23.29 <2e-16 ***
## TrainFact$FoundationCBlock 17515 6300 2.78 0.0055 **
## TrainFact$FoundationPConc 92939 6288 14.78 <2e-16 ***
## TrainFact$FoundationSlab -24926 15115 -1.65 0.0994 .
## TrainFact$FoundationStone 33668 28586 1.18 0.2391
## TrainFact$FoundationWood 53376 40025 1.33 0.1826
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 68600 on 1454 degrees of freedom
## Multiple R-squared: 0.256, Adjusted R-squared: 0.254
## F-statistic: 100 on 5 and 1454 DF, p-value: <2e-16
Nos da un R² 0.2564. Esto equivaldria a una correlacion (si la variable fuera numerica) de 0.50635
Vemos con una de las variables numéricas que calculamos en la sección anterior
#Si comparo con variables numericas
Train<-total%>%filter(is.na(SalePrice)==FALSE)
summary(lm(Train$SalePrice ~ Train$Habitat, data = Train))
##
## Call:
## lm(formula = Train$SalePrice ~ Train$Habitat, data = Train)
##
## Residuals:
## Min 1Q Median 3Q Max
## -467275 -28723 -4117 21521 310323
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 99401 2795 35.6 <2e-16 ***
## Train$Habitat 575911 16500 34.9 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 58700 on 1458 degrees of freedom
## Multiple R-squared: 0.455, Adjusted R-squared: 0.455
## F-statistic: 1.22e+03 on 1 and 1458 DF, p-value: <2e-16
Para esta variable R²=0.4552. Luego la correlacion es 0.674685 Lo comprobamos
cor(x=Train$SalePrice,y=Train$Habitat)
## [1] 0.674692
Es igual. Si la elevamos al cuadrado tenemos 0.45520889
Luego la forma de seleccionar aquellas variables que tienen influencia sobre el precio va a ser calcular el coeficiente de determinación
Ahora bien, tenemos 28 variables categóricas.
Para facilitar esto vamos a usar el paquete FactoMineR.
Tiene varias opciones interesantes para realizar distintas métodos de analisis de datos y entre ellos tiene un método llamado condes() que sirve para describir una variable continua en función de variables continuas y/o categóricas
#Buscamos categorias mas proximas a SalePrice
fact1<-FactoMineR::condes(TrainFact,num.var = 30)
Esto nos genera una lista de tres elementos (como maximo)
R²Nuestro interés esta en la primera matriz.
Teniendo en cuenta que para la selección de las variables cuantitativas significativas poníamos como criterio que la correlacion debía ser superior a 0.5, entonces en este caso R² > (0.5)²=0.25 .
Ese es el limite que ponemos
#Estas son las variables
fact1.cuali<-as.data.frame(fact1[[1]])
kable(fact1.cuali)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| R2 | p.value | |
|---|---|---|
| Neighborhood | 0.545575 | 0.000000 |
| Foundation | 0.256368 | 0.000000 |
| GarageType | 0.249204 | 0.000000 |
| MSSubClass | 0.246316 | 0.000000 |
| MasVnrType | 0.180235 | 0.000000 |
| SaleCondition | 0.135497 | 0.000000 |
| Exterior1st | 0.152773 | 0.000000 |
| Exterior2nd | 0.153830 | 0.000000 |
| SaleType | 0.137287 | 0.000000 |
| MSZoning | 0.107560 | 0.000000 |
| HouseStyle | 0.086313 | 0.000000 |
| CentralAir | 0.063166 | 0.000000 |
| Electrical | 0.059651 | 0.000000 |
| PavedDrive | 0.054540 | 0.000000 |
| RoofStyle | 0.057697 | 0.000000 |
| Fence | 0.035615 | 0.000000 |
| BldgType | 0.034534 | 0.000000 |
| LandContour | 0.025794 | 0.000000 |
| RoofMatl | 0.031413 | 0.000000 |
| Condition1 | 0.032631 | 0.000000 |
| Alley | 0.020408 | 0.000000 |
| LotConfig | 0.021019 | 0.000003 |
| Functional | 0.016480 | 0.000484 |
| Heating | 0.014437 | 0.000753 |
| MiscFeature | 0.007080 | 0.035004 |
| Condition2 | 0.009899 | 0.043426 |
Aqui estan las primeras categorias
fact1.var<-as.data.frame(fact1[[2]])
kable(head(fact1.var))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Estimate | p.value | |
|---|---|---|
| PConc | 64177.3 | 0 |
| NridgHt | 132305.8 | 0 |
| 2-STORY 1946 & NEWER | 85904.5 | 0 |
| New | 88807.5 | 0 |
| Partial | 103104.6 | 0 |
| Attchd | 43339.9 | 0 |
Si vemos las variables solo hay dos que superan un R² de 0.25, pero teniendo en cuenta que como en las variables numéricas no había normalidad y para la correlacion use el método de Spearman que suele dar un valor ligeramente superior al de Pearson, en este caso voy a escoger también las dos variables que se han quedado a las puertas con 0.24
En resumen :
`Neighborhood` ubicaciones físicas dentro de los límites de la ciudad de Ames
Tiene 25 categorias
`MSSubClass` la clase de construcción. Tiene 16 categorias
`Foundation` tipo de cimientos. Tiene 6 categorias
`GarageType` ubicación del garaje Tiene 7 categorias
Son un total de 54 categorias.
Si usamos one hot encoding suponen (25-1)+(16-1)+(6-1)+(7-1)=50 nuevas variables a añadir a las 11 numericas que ya tenemos.
Hay que reducirlas
Las revisamos:
Esta variable tiene 25 categorias. Veamos grafica y ordenadamente por la media y la mediana
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$Neighborhood,TrainFact$SalePrice,FUN = 'mean'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'mean',fill='royalblue')
pru<-pru+stat_summary(fun.data = give.n, geom = "text", fun.y = mean)
pru<-pru+labs(x='Barrio',y='Precio',title='MEDIAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 45,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='red',hjust=.3))
pru
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$Neighborhood,TrainFact$SalePrice,FUN = 'median'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'median',fill='springgreen')
pru<-pru+stat_summary(fun.data = give1.n, geom = "text", fun.y = median)
pru<-pru+labs(x='Barrio',y='Precio',title='MEDIANAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 45,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='darkorange',hjust=.3))
pru
Voy a intentar reducir las variables.
Para eso voy a utilizar una clasificación jerarquica aglomerativa sencilla mediante hclust.
Voy a realizar varias clasificaciones y recalcular el coeficiente de determinación que quedaria antes de decidir .Los clusters van de 3 a 8 agrupaciones
Los resultados los presento juntas las cuatro variables
Aqui solo aparecen los dendogramas
#Preparacion
Resultados.vecinos<-matrix(ncol=3)
#MATRICES DE RESULTADOS
#Prueba clusterizacion medias
#Obtencion de los datos
train.prueba<-TrainFact%>%group_by(Neighborhood)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$Neighborhood
#clusterizacion y guarda de informacion
train.hcl<-hclust(dist(train.prueba2))
ggdendrogram(train.hcl,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Barrio',cutree(train.hcl,k=3))
train.dat[,3]<-paste0('Barrio',cutree(train.hcl,k=4))
train.dat[,4]<-paste0('Barrio',cutree(train.hcl,k=5))
train.dat[,5]<-paste0('Barrio',cutree(train.hcl,k=6))
train.dat[,6]<-paste0('Barrio',cutree(train.hcl,k=7))
train.dat[,7]<-paste0('Barrio',cutree(train.hcl,k=8))
#Se crean nuevas columnas con los clusters calculados
TrainFact$NeighborhoodMean1<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMean1)<- train.dat[,2]
TrainFact$NeighborhoodMean2<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMean2)<- train.dat[,3]
TrainFact$NeighborhoodMean3<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMean3)<- train.dat[,4]
TrainFact$NeighborhoodMean4<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMean4)<- train.dat[,5]
TrainFact$NeighborhoodMean5<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMean5)<- train.dat[,6]
TrainFact$NeighborhoodMean6<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMean6)<- train.dat[,7]
#Prueba clusterizacion medianas
#Obtencion de los datos
train.prueba3<-TrainFact%>%group_by(Neighborhood)
train.prueba4<-train.prueba3%>%summarise(media=median(SalePrice))
rownames(train.prueba4)<-train.prueba4$Neighborhood
#clusterizacion y guarda de informacion
train.hcl2<-hclust(dist(train.prueba4))
ggdendrogram(train.hcl2,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat2<-rownames(train.prueba4)
train.dat2<-as.data.frame(train.dat2)
train.dat2[,2]<-paste0('Barrio', cutree(train.hcl2,k=3))
train.dat2[,3]<-paste0('Barrio', cutree(train.hcl2,k=4))
train.dat2[,4]<-paste0('Barrio',cutree(train.hcl2,k=5))
train.dat2[,5]<-paste0('Barrio',cutree(train.hcl2,k=6))
train.dat2[,6]<-paste0('Barrio',cutree(train.hcl2,k=7))
train.dat2[,7]<-paste0('Barrio', cutree(train.hcl2,k=8))
#Se crean nuevas columnas con los clusters calculados
TrainFact$NeighborhoodMedian1<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMedian1)<- train.dat2[,2]
TrainFact$NeighborhoodMedian2<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMedian2)<- train.dat2[,3]
TrainFact$NeighborhoodMedian3<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMedian3)<- train.dat2[,4]
TrainFact$NeighborhoodMedian4<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMedian4)<- train.dat2[,5]
TrainFact$NeighborhoodMedian5<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMedian5)<- train.dat2[,6]
TrainFact$NeighborhoodMedian6<-TrainFact$Neighborhood
levels(TrainFact$NeighborhoodMedian6)<- train.dat2[,7]
#Presentacion resultados
Resultados.vecinos<-cbind(c(3,4,5,6,7,8,'Todos'))
Resultados.vecinos<-cbind(Resultados.vecinos,c(condes(TrainFact%>%select(Id,NeighborhoodMean1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMean2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMean3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMean4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMean5,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMean6,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,Neighborhood,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.vecinos<-cbind(Resultados.vecinos,c(condes(TrainFact%>%select(Id,NeighborhoodMedian1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMedian2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMedian3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMedian4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMedian5,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,NeighborhoodMedian6,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,Neighborhood,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.vecinos<-as.data.frame(Resultados.vecinos)
colnames(Resultados.vecinos)<-c('Numero clusters','R2 Media','R2 Mediana')
Esta variable tiene 6 categorias. Veamos grafica y ordenadamente por la media y la mediana
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$Foundation,TrainFact$SalePrice,FUN = 'mean'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'mean',fill='royalblue')
pru<-pru+stat_summary(fun.data = give.n, geom = "text", fun.y = mean)
pru<-pru+labs(x='Tipo de cimiento',y='Precio',title='MEDIAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 45,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='red',hjust=.3))
pru
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$Foundation,TrainFact$SalePrice,FUN = 'median'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'median',fill='springgreen')
pru<-pru+stat_summary(fun.data = give1.n, geom = "text", fun.y = median)
pru<-pru+labs(x='Tipo de cimiento',y='Precio',title='MEDIANAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 45,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='darkorange',hjust=.3))
pru
Realizamos la misma operación que con el vecindario, solo que aquí tenemos 6 grupos por lo que los cluster van de 2 a 5
Los resultados los presento juntas las cuatro variables
Aqui solo aparecen los dendogramas
#Preparacion
Resultados.cimientos<-matrix(ncol=3)
#MATRICES DE RESULTADOS
#Prueba clusterizacion medias
#Obtencion de los datos
train.prueba<-TrainFact%>%group_by(Foundation)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$Foundation
#clusterizacion y guarda de informacion
train.hcl<-hclust(dist(train.prueba2))
ggdendrogram(train.hcl,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Cimiento',cutree(train.hcl,k=2))
train.dat[,3]<-paste0('Cimiento',cutree(train.hcl,k=3))
train.dat[,4]<-paste0('Cimiento',cutree(train.hcl,k=4))
train.dat[,5]<-paste0('Cimiento',cutree(train.hcl,k=5))
#Se crean nuevas columnas con los clusters calculados
TrainFact$FoundationMean1<-TrainFact$Foundation
levels(TrainFact$FoundationMean1)<- train.dat[,2]
TrainFact$FoundationMean2<-TrainFact$Foundation
levels(TrainFact$FoundationMean2)<- train.dat[,3]
TrainFact$FoundationMean3<-TrainFact$Foundation
levels(TrainFact$FoundationMean3)<- train.dat[,4]
TrainFact$FoundationMean4<-TrainFact$Foundation
levels(TrainFact$FoundationMean4)<- train.dat[,5]
#Prueba clusterizacion medianas
#Obtencion de los datos
train.prueba3<-TrainFact%>%group_by(Foundation)
train.prueba4<-train.prueba3%>%summarise(media=median(SalePrice))
rownames(train.prueba4)<-train.prueba4$Foundation
train.hcl2<-hclust(dist(train.prueba4))
ggdendrogram(train.hcl2,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat2<-rownames(train.prueba4)
train.dat2<-as.data.frame(train.dat2)
train.dat2[,2]<-paste0('Cimiento', cutree(train.hcl2,k=2))
train.dat2[,3]<-paste0('Cimiento',cutree(train.hcl2,k=3))
train.dat2[,4]<-paste0('Cimiento',cutree(train.hcl2,k=4))
train.dat2[,5]<-paste0('Cimiento',cutree(train.hcl2,k=5))
#Se crean nuevas columnas con los clusters calculados
TrainFact$FoundationMedian1<-TrainFact$Foundation
levels(TrainFact$FoundationMedian1)<- train.dat2[,2]
TrainFact$FoundationMedian2<-TrainFact$Foundation
levels(TrainFact$FoundationMedian2)<- train.dat2[,3]
TrainFact$FoundationMedian3<-TrainFact$Foundation
levels(TrainFact$FoundationMedian3)<- train.dat2[,4]
TrainFact$FoundationMedian4<-TrainFact$Foundation
levels(TrainFact$FoundationMedian4)<- train.dat2[,5]
#Presentacion resultados
Resultados.cimientos<-cbind(c(2,3,4,5,'Todos'))
Resultados.cimientos<-cbind(Resultados.cimientos,c(condes(TrainFact%>%select(Id,FoundationMean1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,FoundationMean2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,FoundationMean3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,FoundationMean4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,Foundation,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.cimientos<-cbind(Resultados.cimientos,c(condes(TrainFact%>%select(Id,FoundationMedian1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,FoundationMedian2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,FoundationMedian3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,FoundationMedian4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,Foundation,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.cimientos<-as.data.frame(Resultados.cimientos)
colnames(Resultados.cimientos)<-c('Numero clusters','R2 Media','R2 Mediana')
Esta variable tiene 7 categorias. Veamos grafica y ordenadamente por la media y la mediana
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$GarageType,TrainFact$SalePrice,FUN = 'mean'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'mean',fill='royalblue')
pru<-pru+stat_summary(fun.data = give.n, geom = "text", fun.y = mean)
pru<-pru+labs(x='Ubicacion Garaje',y='Precio',title='MEDIAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 45,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='red',hjust=.3))
pru
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$GarageType,TrainFact$SalePrice,FUN = 'median'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'median',fill='springgreen')
pru<-pru+stat_summary(fun.data = give1.n, geom = "text", fun.y = median)
pru<-pru+labs(x='Ubicacion Garaje',y='Precio',title='MEDIANAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 45,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='darkorange',hjust=.3))
pru
Realizamos la misma operación que con el vecindario, solo que aquí tenemos 7 grupos por lo que los cluster van de 2 a 5
Los resultados los presento juntas las cuatro variables
Aqui solo aparecen los dendogramas
#Preparacion
Resultados.garage<-matrix(ncol=3)
#MATRICES DE RESULTADOS
#Prueba clusterizacion medias
#Obtencion de los datos
train.prueba<-TrainFact%>%group_by(GarageType)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$GarageType
#clusterizacion y guarda de informacion
train.hcl<-hclust(dist(train.prueba2))
ggdendrogram(train.hcl,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('garage',cutree(train.hcl,k=2))
train.dat[,3]<-paste0('garage',cutree(train.hcl,k=3))
train.dat[,4]<-paste0('garage',cutree(train.hcl,k=4))
train.dat[,5]<-paste0('garage',cutree(train.hcl,k=5))
#Se crean nuevas columnas con los clusters calculados
TrainFact$GarageTypeMean1<-TrainFact$GarageType
levels(TrainFact$GarageTypeMean1)<- train.dat[,2]
TrainFact$GarageTypeMean2<-TrainFact$GarageType
levels(TrainFact$GarageTypeMean2)<- train.dat[,3]
TrainFact$GarageTypeMean3<-TrainFact$GarageType
levels(TrainFact$GarageTypeMean3)<- train.dat[,4]
TrainFact$GarageTypeMean4<-TrainFact$GarageType
levels(TrainFact$GarageTypeMean4)<- train.dat[,5]
#Prueba clusterizacion medianas
#Obtencion de los datos
train.prueba3<-TrainFact%>%group_by(GarageType)
train.prueba4<-train.prueba3%>%summarise(media=median(SalePrice))
rownames(train.prueba4)<-train.prueba4$GarageType
#clusterizacion y guarda de informacion
train.hcl2<-hclust(dist(train.prueba4))
ggdendrogram(train.hcl2,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat2<-rownames(train.prueba4)
train.dat2<-as.data.frame(train.dat2)
train.dat2[,2]<-paste0('garage', cutree(train.hcl2,k=2))
train.dat2[,3]<-paste0('garage',cutree(train.hcl2,k=3))
train.dat2[,4]<-paste0('garage',cutree(train.hcl2,k=4))
train.dat2[,5]<-paste0('garage',cutree(train.hcl2,k=5))
#Se crean nuevas columnas con los clusters calculados
TrainFact$GarageTypeMedian1<-TrainFact$GarageType
levels(TrainFact$GarageTypeMedian1)<- train.dat2[,2]
TrainFact$GarageTypeMedian2<-TrainFact$GarageType
levels(TrainFact$GarageTypeMedian2)<- train.dat2[,3]
TrainFact$GarageTypeMedian3<-TrainFact$GarageType
levels(TrainFact$GarageTypeMedian3)<- train.dat2[,4]
TrainFact$GarageTypeMedian4<-TrainFact$GarageType
levels(TrainFact$GarageTypeMedian4)<- train.dat2[,5]
#Presentacion resultados
Resultados.garage<-cbind(c(2,3,4,5,'Todos'))
Resultados.garage<-cbind(Resultados.garage,c(condes(TrainFact%>%select(Id,GarageTypeMean1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageTypeMean2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageTypeMean3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageTypeMean4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageType,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.garage<-cbind(Resultados.garage,c(condes(TrainFact%>%select(Id,GarageTypeMedian1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageTypeMedian2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageTypeMedian3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageTypeMedian4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,GarageType,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.garage<-as.data.frame(Resultados.garage)
colnames(Resultados.garage)<-c('Numero clusters','R2 Media','R2 Mediana')
Esta variable tiene 16 categorias. Veamos grafica y ordenadamente por la media y la mediana
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$MSSubClass,TrainFact$SalePrice,FUN = 'mean'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'mean',fill='royalblue')
pru<-pru+stat_summary(fun.data = give.n, geom = "text", fun.y = mean)
pru<-pru+labs(x='Clase Construccion',y='Precio',title='MEDIAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 60,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='red',hjust=.3))
pru
pru<-ggplot(data=TrainFact,aes(x=reorder(TrainFact$MSSubClass,TrainFact$SalePrice,FUN = 'median'), y=TrainFact$SalePrice))
pru<-pru+geom_bar(stat = 'summary',fun.y = 'median',fill='springgreen')
pru<-pru+stat_summary(fun.data = give1.n, geom = "text", fun.y = median)
pru<-pru+labs(x='Clase Construccion',y='Precio',title='MEDIANAS')+scale_y_continuous(labels = scales::comma)
pru<-pru+theme(axis.text.x = element_text(angle = 60,hjust=1,vjust=1),title = element_text(color="mediumblue",size=12,lineheight = 1),plot.title = element_text(color='darkorange',hjust=.3))
pru
Esta variable es mas peculiar. Vemos sus categorías y apariciones
kable(table(TrainFact$MSSubClass))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| 1-STORY 1946 & NEWER ALL STYLES | 536 |
| 1-STORY 1945 & OLDER | 69 |
| 1-STORY W/FINISHED ATTIC ALL AGES | 4 |
| 1-1/2 STORY - UNFINISHED ALL AGES | 12 |
| 1-1/2 STORY FINISHED ALL AGES | 144 |
| 2-STORY 1946 & NEWER | 299 |
| 2-STORY 1945 & OLDER | 60 |
| 2-1/2 STORY ALL AGES | 16 |
| SPLIT OR MULTI-LEVEL | 58 |
| SPLIT FOYER | 20 |
| DUPLEX - ALL STYLES AND AGES | 52 |
| 1-STORY PUD (Planned Unit Development) - 1946 & NEWER | 87 |
| 1-1/2 STORY PUD - ALL AGES | 0 |
| 2-STORY PUD - 1946 & NEWER | 63 |
| PUD - MULTILEVEL - INCL SPLIT LEV/FOYER | 10 |
| 2 FAMILY CONVERSION - ALL STYLES AND AGES | 30 |
Tenemos una categoria con 0 casos en el Train
Buscamos en el dataset Test
TestFact<-TotalFact%>%filter(is.na(SalePrice)==TRUE)
kable(table(TestFact$MSSubClass))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| 1-STORY 1946 & NEWER ALL STYLES | 543 |
| 1-STORY 1945 & OLDER | 70 |
| 1-STORY W/FINISHED ATTIC ALL AGES | 2 |
| 1-1/2 STORY - UNFINISHED ALL AGES | 6 |
| 1-1/2 STORY FINISHED ALL AGES | 143 |
| 2-STORY 1946 & NEWER | 276 |
| 2-STORY 1945 & OLDER | 68 |
| 2-1/2 STORY ALL AGES | 7 |
| SPLIT OR MULTI-LEVEL | 60 |
| SPLIT FOYER | 28 |
| DUPLEX - ALL STYLES AND AGES | 57 |
| 1-STORY PUD (Planned Unit Development) - 1946 & NEWER | 95 |
| 1-1/2 STORY PUD - ALL AGES | 1 |
| 2-STORY PUD - 1946 & NEWER | 65 |
| PUD - MULTILEVEL - INCL SPLIT LEV/FOYER | 7 |
| 2 FAMILY CONVERSION - ALL STYLES AND AGES | 31 |
Tiene 1 caso, luego no se puede eliminar directamente de todo el conjunto, pero si debemos NO tomarlo en consideracion para la reduccion de variables porque si no trastornaria todos los calculos
TestFact%>%filter(MSSubClass=='1-1/2 STORY PUD - ALL AGES')%>%select(Id)#Descarto este level para el calculo
TrainFact$MSSubClass<-droplevels(TrainFact$MSSubClass,exclude='1-1/2 STORY PUD - ALL AGES')
kable(table(TrainFact$MSSubClass))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| 1-STORY 1946 & NEWER ALL STYLES | 536 |
| 1-STORY 1945 & OLDER | 69 |
| 1-STORY W/FINISHED ATTIC ALL AGES | 4 |
| 1-1/2 STORY - UNFINISHED ALL AGES | 12 |
| 1-1/2 STORY FINISHED ALL AGES | 144 |
| 2-STORY 1946 & NEWER | 299 |
| 2-STORY 1945 & OLDER | 60 |
| 2-1/2 STORY ALL AGES | 16 |
| SPLIT OR MULTI-LEVEL | 58 |
| SPLIT FOYER | 20 |
| DUPLEX - ALL STYLES AND AGES | 52 |
| 1-STORY PUD (Planned Unit Development) - 1946 & NEWER | 87 |
| 2-STORY PUD - 1946 & NEWER | 63 |
| PUD - MULTILEVEL - INCL SPLIT LEV/FOYER | 10 |
| 2 FAMILY CONVERSION - ALL STYLES AND AGES | 30 |
Podemos ver que ya no figura
Realizamos la misma operación que con el vecindario, solo que aquí tenemos 16 (15 con la que no tratamos transitoriamente) grupos por lo que los cluster van de 3 a 8
Los resultados los presento juntas las cuatro variables
Aqui solo aparecen los dendogramas
#Preparacion
Resultados.clases<-matrix(ncol=3)
#MATRICES DE RESULTADOS
#Prueba clusterizacion medias
#Obtencion de los datos
train.prueba<-TrainFact%>%group_by(MSSubClass)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$MSSubClass
#clusterizacion y guarda de informacion
train.hcl<-hclust(dist(train.prueba2))
ggdendrogram(train.hcl,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Clase',cutree(train.hcl,k=3))
train.dat[,3]<-paste0('Clase',cutree(train.hcl,k=4))
train.dat[,4]<-paste0('Clase',cutree(train.hcl,k=5))
train.dat[,5]<-paste0('Clase',cutree(train.hcl,k=6))
train.dat[,6]<-paste0('Clase',cutree(train.hcl,k=7))
train.dat[,7]<-paste0('Clase',cutree(train.hcl,k=8))
#Se crean nuevas columnas con los clusters calculados
TrainFact$MSSubClassMean1<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMean1)<- train.dat[,2]
TrainFact$MSSubClassMean2<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMean2)<- train.dat[,3]
TrainFact$MSSubClassMean3<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMean3)<- train.dat[,4]
TrainFact$MSSubClassMean4<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMean4)<- train.dat[,5]
TrainFact$MSSubClassMean5<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMean5)<- train.dat[,6]
TrainFact$MSSubClassMean6<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMean6)<- train.dat[,7]
#Prueba clusterizacion medianas
#Obtencion de los datos
train.prueba3<-TrainFact%>%group_by(MSSubClass)
train.prueba4<-train.prueba3%>%summarise(media=median(SalePrice))
rownames(train.prueba4)<-train.prueba4$MSSubClass
#clusterizacion y guarda de informacion
train.hcl2<-hclust(dist(train.prueba4))
ggdendrogram(train.hcl2,rotate=TRUE,size=20,theme_dendro = FALSE, color='black')train.dat2<-rownames(train.prueba4)
train.dat2<-as.data.frame(train.dat2)
train.dat2[,2]<-paste0('Clase', cutree(train.hcl2,k=3))
train.dat2[,3]<-paste0('Clase',cutree(train.hcl2,k=4))
train.dat2[,4]<-paste0('Clase',cutree(train.hcl2,k=5))
train.dat2[,5]<-paste0('Clase',cutree(train.hcl2,k=6))
train.dat2[,6]<-paste0('Clase',cutree(train.hcl2,k=7))
train.dat2[,7]<-paste0('Clase',cutree(train.hcl2,k=8))
#Se crean nuevas columnas con los clusters calculados
TrainFact$MSSubClassMedian1<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMedian1)<- train.dat2[,2]
TrainFact$MSSubClassMedian2<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMedian2)<- train.dat2[,3]
TrainFact$MSSubClassMedian3<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMedian3)<- train.dat2[,4]
TrainFact$MSSubClassMedian4<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMedian4)<- train.dat2[,5]
TrainFact$MSSubClassMedian5<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMedian5)<- train.dat2[,6]
TrainFact$MSSubClassMedian6<-TrainFact$MSSubClass
levels(TrainFact$MSSubClassMedian6)<- train.dat2[,7]
#Presentacion resultados
Resultados.clases<-cbind(c(3,4,5,6,7,8,'Todos'))
Resultados.clases<-cbind(Resultados.clases,c(condes(TrainFact%>%select(Id,MSSubClassMean1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMean2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMean3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMean4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMean5,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMean6,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClass,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.clases<-cbind(Resultados.clases,c(condes(TrainFact%>%select(Id,MSSubClassMedian1,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMedian2,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMedian3,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMedian4,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMedian5,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClassMedian6,SalePrice),num.var=3,proba = 0.05)[[1]][[1]],condes(TrainFact%>%select(Id,MSSubClass,SalePrice),num.var=3,proba = 0.05)[[1]][[1]]))
Resultados.clases<-as.data.frame(Resultados.clases)
colnames(Resultados.clases)<-c('Numero clusters','R2 Media','R2 Mediana')
He obtenido en las siguientes tablas los coeficientes de determinación las variables agrupadas en diferentes clusters.
Tambien figura el valor del que partíamos
#Añado la diferencia en columna
options(digits=8)
Resultados.cimientos$Diferencia_Media_Mediana<-as.factor(as.numeric(levels(Resultados.cimientos$`R2 Media`))[Resultados.cimientos$`R2 Media`]-as.numeric(levels(Resultados.cimientos$`R2 Mediana`))[Resultados.cimientos$`R2 Mediana`])
Resultados.clases$Diferencia_Media_Mediana<-as.factor(as.numeric(levels(Resultados.clases$`R2 Media`))[Resultados.clases$`R2 Media`]-as.numeric(levels(Resultados.clases$`R2 Mediana`))[Resultados.clases$`R2 Mediana`])
Resultados.garage$Diferencia_Media_Mediana<-as.factor(as.numeric(levels(Resultados.garage$`R2 Media`))[Resultados.garage$`R2 Media`]-as.numeric(levels(Resultados.garage$`R2 Mediana`))[Resultados.garage$`R2 Mediana`])
Resultados.vecinos$Diferencia_Media_Mediana<-as.factor(as.numeric(levels(Resultados.vecinos$`R2 Media`))[Resultados.vecinos$`R2 Media`]-as.numeric(levels(Resultados.vecinos$`R2 Mediana`))[Resultados.vecinos$`R2 Mediana`])
La idea es optimizar el numero que nos quedaremos teniendo en cuenta que ya tenemos 11 variables numéricas
Lo primero mas destacable que se observa es que no hay diferencias tomando la media o la mediana de los precios en la variable GarageType.
Esto se explica porque el dendograma es idéntico en ambos supuestos. Aqui se puede ver
Lo segundo que destaca es que en la gran mayoría de los supuestos tomar como referencia la media del precio suele ser mejor que hacerlo con la mediana. La diferencia es positiva en la mayoría de los casos.
Como criterios:
En primer lugar seguir el orden asignado por el coeficiente de determinación general. Tendran preferencias las categorías de Neighborhood, sobre el resto, luego Foundation, GarageType y por ultimo MSSubClass
Luego elegir aquel agrupamiento en que el paso a un numero de cluster menor suponga una diferencia muy superior a la que supuso el paso anterior (de un numero de clusters mayor) Vemos todo en una tabla con una vista mas amigable
kable(Resultados.vecinos)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))%>%row_spec(2,background = 'yellow')%>%row_spec(3,background = 'lawngreen')| Numero clusters | R2 Media | R2 Mediana | Diferencia_Media_Mediana |
|---|---|---|---|
| 3 | 0.510288922673946 | 0.510288922673946 | 0 |
| 4 | 0.520752826029343 | 0.519728064432752 | 0.00102476159659104 |
| 5 | 0.534661463050312 | 0.533467614063988 | 0.00119384898632402 |
| 6 | 0.536798653780542 | 0.533811092372337 | 0.002987561408205 |
| 7 | 0.541121980460839 | 0.539159180649222 | 0.00196279981161707 |
| 8 | 0.542448822452204 | 0.54101354304445 | 0.00143527940775401 |
| Todos | 0.545574990809563 | 0.545574990809563 | 0 |
kable(Resultados.cimientos)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))%>%row_spec(1,background = 'orange1')%>%row_spec(3,background = 'yellow')%>%row_spec(4,background = 'lawngreen')| Numero clusters | R2 Media | R2 Mediana | Diferencia_Media_Mediana |
|---|---|---|---|
| 2 | 0.0568254698693131 | 0.247754678851469 | -0.190929208982156 |
| 3 | 0.254395725745173 | 0.248262307945321 | 0.00613341779985199 |
| 4 | 0.2548092461983 | 0.252170668995711 | 0.00263857720258898 |
| 5 | 0.256199967397587 | 0.255658927697032 | 0.000541039700554968 |
| Todos | 0.256368401530415 | 0.256368401530415 | 0 |
kable(Resultados.garage)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))%>%row_spec(2,background = 'orange1')%>%row_spec(3,background = 'lawngreen')| Numero clusters | R2 Media | R2 Mediana | Diferencia_Media_Mediana |
|---|---|---|---|
| 2 | 0.216280939876281 | 0.216280939876281 | 0 |
| 3 | 0.224281569646271 | 0.224281569646271 | 0 |
| 4 | 0.247622864331931 | 0.247622864331931 | 0 |
| 5 | 0.249122673737389 | 0.249122673737389 | 0 |
| Todos | 0.249204230504291 | 0.249204230504291 | 0 |
kable(Resultados.clases)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))%>%row_spec(1,background = 'orange1')%>%row_spec(3,background = 'yellow')%>%row_spec(4,background = 'lawngreen')| Numero clusters | R2 Media | R2 Mediana | Diferencia_Media_Mediana |
|---|---|---|---|
| 3 | 0.174786074913226 | 0.188741697652476 | -0.01395562273925 |
| 4 | 0.235584333942853 | 0.230629760361157 | 0.00495457358169599 |
| 5 | 0.239410301887266 | 0.241858637138703 | -0.00244833525143701 |
| 6 | 0.243776881430928 | 0.241878911205326 | 0.00189797022560198 |
| 7 | 0.245698829986421 | 0.241915556005449 | 0.003783273980972 |
| 8 | 0.24576269922555 | 0.242459440131863 | 0.00330325909368701 |
| Todos | 0.246315972817565 | 0.246315972817565 | 0 |
Hemos descartado trabajar con la mediana.
Descartamos primero aquellas con un coeficiente muy bajo. Las tacho en naranja. Ese es el minimo
Marco la fila de las casillas de salto mas grandes en amarillo. Elegir el valor de cluster anterior es una buena forma de comenzar
Tenemos que la primera elección es :
Son un total de 20 categorias.
En las dos ultimas (Garage y Clases ) parece difícil reducir mas sin que haya una perdida importante, y ya están muy al limite.
Quizas podríamos reducir uno o dos mas en Cimientos, pero la cantidad de 31 variables numéricas , entre las originales y las reconvertidas puede ser una buena cifra
Para realizar la actualización recuperamos parte del código con el numero cluster que hemos decidido
#Escojo los agrupamientos
#Vecinos 5 clusters
train.prueba<-TrainFact%>%group_by(Neighborhood)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$Neighborhood
train.hcl<-hclust(dist(train.prueba2))
train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Barrio',cutree(train.hcl,k=5))
TotalFact$NeighborhoodMean4<-TotalFact$Neighborhood
levels(TotalFact$NeighborhoodMean4)<- train.dat[,2]
total$Vecindario<-TotalFact$NeighborhoodMean4
#Cimientos 5 clusters
train.prueba<-TrainFact%>%group_by(Foundation)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$Foundation
train.hcl<-hclust(dist(train.prueba2))
train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Cimientos',cutree(train.hcl,k=5))
TotalFact$FoundationMean4<-TotalFact$Foundation
levels(TotalFact$FoundationMean4)<- train.dat[,2]
total$Cimientos<-TotalFact$FoundationMean4
#Garage 4 clusters
train.prueba<-TrainFact%>%group_by(GarageType)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$GarageType
train.hcl<-hclust(dist(train.prueba2))
train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Garage',cutree(train.hcl,k=4))
TotalFact$GarageTypeMean3<-TotalFact$GarageType
levels(TotalFact$GarageTypeMean3)<- train.dat[,2]
total$UbicaGarage<-TotalFact$GarageTypeMean3
Para el caso de la variable MSSubClass tenemos que recordar que para hacer la agrupación teníamos una categoría que se encontraba en el dataset Test pero no en el Train, luego dejamos esa categoría apartada , pero ahora hay que introducirla manualmente en un cluster.
Para encontrar en que cluster voy a buscar registros con ciertas variables muy correlacionadas con el objetivo y que se parezcan a las del que buscamos.
Voy a usar las variables numéricas Habitat, AreaPiso y OverallQual
Primero identificamos el registro
#Clases 6 clusters
#TrainFact$MSSubClassMean4
#Busqueda
kable(total%>%filter(MSSubClass=='1-1/2 STORY PUD - ALL AGES')%>%select(Id,AreaPiso,Habitat,OverallQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | AreaPiso | Habitat | OverallQual |
|---|---|---|---|
| 2819 | 0.09323653 | 0.17182298 | 0.66666667 |
A continuacion escogemos las ventanas de los parametros para el filtrado
0.06<AreaPiso<0.12
0.16<Habitat<0.18
0.6<OverallQual<0.7
Filtramos por aproximacion a estas variables
prue<-total%>%filter(OverallQual>0.6 & OverallQual<0.7)%>%select(Id,AreaPiso,Habitat,MSSubClass)
prue<-prue%>%filter(AreaPiso>0.06 & AreaPiso<0.12)
prue<-prue%>%filter(Habitat>0.16 & Habitat<0.18)%>%select(Id,MSSubClass)
kable(table(prue$MSSubClass))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Var1 | Freq |
|---|---|
| 1-STORY 1946 & NEWER ALL STYLES | 0 |
| 1-STORY 1945 & OLDER | 0 |
| 1-STORY W/FINISHED ATTIC ALL AGES | 0 |
| 1-1/2 STORY - UNFINISHED ALL AGES | 0 |
| 1-1/2 STORY FINISHED ALL AGES | 0 |
| 2-STORY 1946 & NEWER | 9 |
| 2-STORY 1945 & OLDER | 0 |
| 2-1/2 STORY ALL AGES | 0 |
| SPLIT OR MULTI-LEVEL | 1 |
| SPLIT FOYER | 0 |
| DUPLEX - ALL STYLES AND AGES | 0 |
| 1-STORY PUD (Planned Unit Development) - 1946 & NEWER | 0 |
| 1-1/2 STORY PUD - ALL AGES | 1 |
| 2-STORY PUD - 1946 & NEWER | 0 |
| PUD - MULTILEVEL - INCL SPLIT LEV/FOYER | 0 |
| 2 FAMILY CONVERSION - ALL STYLES AND AGES | 0 |
Hay 11 registros con campos parecidos, incluido el que buscamos.
La gran mayoría 9 tienen en MSSubClass 2-STORY 1946 & NEWER.
Donde esté esta categoría agrupada pondremos la que nos falta
#Modificacion
train.prueba<-TrainFact%>%group_by(MSSubClass)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$MSSubClass
train.hcl<-hclust(dist(train.prueba2))
train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Clase',cutree(train.hcl,k=6))
TotalFact$MSSubClassMean4<-TotalFact$MSSubClass
Hasta aquí es todo igual.
Vamos a buscar en que grupo queda 2-STORY 1946 & NEWER que es donde hay que meter el nivel de factor que nos falta
#Vemos el que falta y se añade
kable(train.dat)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| train.dat | V2 |
|---|---|
| 1-STORY 1946 & NEWER ALL STYLES | Clase1 |
| 1-STORY 1945 & OLDER | Clase2 |
| 1-STORY W/FINISHED ATTIC ALL AGES | Clase3 |
| 1-1/2 STORY - UNFINISHED ALL AGES | Clase2 |
| 1-1/2 STORY FINISHED ALL AGES | Clase3 |
| 2-STORY 1946 & NEWER | Clase4 |
| 2-STORY 1945 & OLDER | Clase5 |
| 2-1/2 STORY ALL AGES | Clase1 |
| SPLIT OR MULTI-LEVEL | Clase5 |
| SPLIT FOYER | Clase3 |
| DUPLEX - ALL STYLES AND AGES | Clase6 |
| 1-STORY PUD (Planned Unit Development) - 1946 & NEWER | Clase1 |
| 2-STORY PUD - 1946 & NEWER | Clase6 |
| PUD - MULTILEVEL - INCL SPLIT LEV/FOYER | Clase2 |
| 2 FAMILY CONVERSION - ALL STYLES AND AGES | Clase6 |
Es el elemento numero 9 que corresponde a Clase4
Ademas
levels(total$MSSubClass)
## [1] "1-STORY 1946 & NEWER ALL STYLES"
## [2] "1-STORY 1945 & OLDER"
## [3] "1-STORY W/FINISHED ATTIC ALL AGES"
## [4] "1-1/2 STORY - UNFINISHED ALL AGES"
## [5] "1-1/2 STORY FINISHED ALL AGES"
## [6] "2-STORY 1946 & NEWER"
## [7] "2-STORY 1945 & OLDER"
## [8] "2-1/2 STORY ALL AGES"
## [9] "SPLIT OR MULTI-LEVEL"
## [10] "SPLIT FOYER"
## [11] "DUPLEX - ALL STYLES AND AGES"
## [12] "1-STORY PUD (Planned Unit Development) - 1946 & NEWER"
## [13] "1-1/2 STORY PUD - ALL AGES"
## [14] "2-STORY PUD - 1946 & NEWER"
## [15] "PUD - MULTILEVEL - INCL SPLIT LEV/FOYER"
## [16] "2 FAMILY CONVERSION - ALL STYLES AND AGES"
Tiene que ir en la posicion numero 13.
La añadiremos como una fila a train.dat desplazando el resto
#Añado el level
levels(train.dat$train.dat)<-c(levels(train.dat$train.dat),'1-1/2 STORY PUD - ALL AGES')
#Añado la fila
train.dat<-rbind(train.dat,c('1-1/2 STORY PUD - ALL AGES','Clase4'))
#Cojo levels originales como vector
lev<-as.vector(levels(total$MSSubClass))
#Comparo y ordeno
train.dat<-train.dat[match(lev,train.dat$train.dat),]
#Ya estan ordenados los level y los valores que les sutituyen
levels(TotalFact$MSSubClassMean4)<-train.dat$V2
total$Clases<-TotalFact$MSSubClassMean4
Para buscar el modelo que mas conviene tomar para realizar la prediccion que se pide voy a dividir el conjunto de predictores en varias partes.
Por un lado aquellos predictores que son desde el origen numéricos y que además son continuos o discretos con un numero amplio de intervalos
Son :Antiguedad, AntGarage, AreaPiso, GarageTotal, Habitat y OverallQual
En otro grupo los predictores numéricos de origen ordinal con un numero pequeño de intevalos.
Son : BsmtQual, ExterQual, FireplaceQu, GarageFinish y KitchenQual
En el ultimo grupo los predictores de origen categoricos
Son : Neighborhood, Foundation, GarageType y MSSubClass
Esta división solo la hago en sentido grafico para apreciar mejor las diversas características
Voy a aplicar un modelo lineal multiple, uno polinómico, otro suavizado tipo Loess y uno suavizado con curvas Spline y vamos a comparar en cada variable con respecto a la objetivo SalePrice
Aunque el grafico es muy completo entre toda las variables solos nos interesa la fila inferior donde aparecen los graficos de cada predictor en función del objetivo
Podemos ver también en las primeras graficas en la columna mas a la derecha el valor de correlacion de SalePrice con el resto de variables
Primero una vision de conjunto
#preparacion datos
Model1<-total%>%select(Id,Antiguedad,AntGarage,AreaPiso,GarageTotal,Habitat,OverallQual,SalePrice)
ModelTrain1<-Model1%>%filter(is.na(SalePrice)==FALSE)%>%select(-Id)
GGP1<-ggpairs(ModelTrain1, lower = list(continuous = my_rg1), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: Modelo Lineal (lm)-Cyan y Suavizado Local(Loess)-Rojo")
GGP1<-GGP1+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP1
GGP2<-ggpairs(ModelTrain1, lower = list(continuous = my_rg2), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: B Splines (bs)-Purpura y Modelo lineal polinomico (poly)-Naranja")
GGP2<-GGP2+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP2
GGP3<-ggpairs(ModelTrain1, lower = list(continuous = my_rg3), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: B Splines (bs)-Verde y Suavizado Local(Loess)-Rojo")
GGP3<-GGP3+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP3
Vemos ahora en detalle
#Plots individuales
p11<-getPlot(GGP1,7,1)
p12<-getPlot(GGP1,7,2)
p13<-getPlot(GGP1,7,3)
p14<-getPlot(GGP1,7,4)
p15<-getPlot(GGP1,7,5)
p16<-getPlot(GGP1,7,6)
p31<-getPlot(GGP3,7,1)
p36<-getPlot(GGP3,7,6)
p11<-p11+labs(title="Antiguedad")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p12<-p12+labs(title="AntGarage")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p13<-p13+labs(title="AreaPiso")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p14<-p14+labs(title="GarageTotal")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p15<-p15+labs(title="Habitat")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p16<-p16+labs(title="OverallQual")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p31<-p31+labs(title="Antiguedad")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p36<-p36+labs(title="OverallQual")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))p11Antigüedad: Se adapta mejor la curva suavizada que la recta
p12AntGarage: la especificidad de los datos (como poner antigüedad a los que no tienen garaje) hace que salga una grafica extraña, pero me decanto por el modelo lineal
p13AreaPiso: los outliers hacen que las curvas no sirvan
p14GarageTotal: Es el mismo caso que el anterior
p15Habitat: Es el mismo caso que el anterior
p16OverallQual: Pasa algo parecido que con la antigüedad. Se adapta mejor una curva
Vemos las dos variables que se adaptan mejor a las curvas en comparativa de Loess y B Spline
p31p36
Hay pequeñas diferencias pero no son apreciables para decantarse por un modelo . Lo veremos numericamente
Primero una vision de conjunto
#Preparacion de datos
Model2<-total%>%select(Id,BsmtQual,ExterQual,FireplaceQu,GarageFinish,KitchenQual,SalePrice)
ModelTrain2<-Model2%>%filter(is.na(SalePrice)==FALSE)%>%select(-Id)
GGP4<-ggpairs(ModelTrain2, lower = list(continuous = my_rg1), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: Modelo Lineal (lm)-Cyan y Suavizado Local(Loess)-Rojo")
GGP4<-GGP4+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP4GGP5<-ggpairs(ModelTrain2, lower = list(continuous = my_rg2), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: B Splines (bs)-Purpura y Modelo lineal polinomico (poly)-Naranja")
GGP5<-GGP5+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP5GGP6<-ggpairs(ModelTrain2, lower = list(continuous = my_rg4), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: Modelo lineal con intervalo de confianza - Purpura")
GGP6<-GGP6+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP6De las tres grafica la mas interesante es esta ultima. En la primera nos queda claro que un ajuste de regresión local con Loess no sirve, salvo quizás en FireplaceQu
Veamos ahora una por una como se adaptan mejor si a un modelo lineal o suavizado con B Splines
#Plots individuales
p51<-getPlot(GGP5,6,1)
p52<-getPlot(GGP5,6,2)
p53<-getPlot(GGP5,6,3)
p54<-getPlot(GGP5,6,4)
p55<-getPlot(GGP5,6,5)
p51<-p51+labs(title="BsmtQual")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p52<-p52+labs(title="ExterQual")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p53<-p53+labs(title="FireplaceQu")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p54<-p54+labs(title="GarageFinish")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p55<-p55+labs(title="KitchenQual")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))p51p52p53p54p55A la hora de comparar entre el modelo lineal (línea purpura) y las curvas suavizadas B Splines vemos que todas quedan mejor explicadas por la B Spline salvo FireplaceQu pero esta solo se verá numericamente
En cuanto al resto de variables categoricas , no se puede hacer ningún análisis grafico por la propia composición de la variable.
Si podemos ver una matriz de graficos de sus variables origen ordenadas por la variable destino
#preparacion
Model3<-total%>%select(Id,Neighborhood,Foundation,GarageType,MSSubClass,SalePrice)
ModelTrain3<-Model3%>%filter(is.na(SalePrice)==FALSE)%>%select(-Id)
ModelTrain3$Neighborhood<-reorder(ModelTrain3$Neighborhood,ModelTrain3$SalePrice,FUN = 'mean')
ModelTrain3$Foundation<-reorder(ModelTrain3$Foundation,ModelTrain3$SalePrice,FUN = 'mean')
ModelTrain3$GarageType<-reorder(ModelTrain3$GarageType,ModelTrain3$SalePrice,FUN = 'mean')
ModelTrain3$MSSubClass<-reorder(ModelTrain3$MSSubClass,ModelTrain3$SalePrice,FUN = 'mean')
GGP7<-ggpairs(ModelTrain3, lower = list(combo = 'box'), diag = list(continuous = "densityDiag"), axisLabels = "none",cardinality_threshold = 25,title='Variables Categoricas')
GGP7<-GGP7+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP7GGP8<-ggpairs(ModelTrain3, lower = list(combo = 'dot'), diag = list(continuous = "densityDiag",discrete='barDiag'), axisLabels = "none",cardinality_threshold = 25,title='Variables Categoricas')
GGP8<-GGP8+theme(plot.title = element_text(color='darkorange',hjust=.3,size=32,lineheight = 1))
GGP8
Si vemos en detalle las graficas
#Plots individuales
p81<-getPlot(GGP8,5,1)
p82<-getPlot(GGP8,5,2)
p83<-getPlot(GGP8,5,3)
p84<-getPlot(GGP8,5,4)
p81<-p81+labs(title="Neighborhood")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p82<-p82+labs(title="Foundation")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p83<-p83+labs(title="GarageType")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p84<-p84+labs(title="MSSubClass")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))p81p82p83p84Vemos que se puede apreciar cierta linealidad
Si vemos ahora con la agrupación de clusters y ordenadas
#DUMMYS
#preparacion
Model4<-total%>%select(Id,Vecindario,Cimientos,UbicaGarage,Clases,SalePrice)
ModelTrain4<-Model4%>%filter(is.na(SalePrice)==FALSE)%>%select(-Id)
ModelTrain4$Vecindario<-reorder(ModelTrain4$Vecindario,ModelTrain4$SalePrice,FUN = 'mean')
ModelTrain4$Cimientos<-reorder(ModelTrain4$Cimientos,ModelTrain4$SalePrice,FUN = 'mean')
ModelTrain4$UbicaGarage<-reorder(ModelTrain4$UbicaGarage,ModelTrain4$SalePrice,FUN = 'mean')
ModelTrain4$Clases<-reorder(ModelTrain4$Clases,ModelTrain4$SalePrice,FUN = 'mean')
GGP9<-ggpairs(ModelTrain4, lower = list(combo='dot'), diag = list(continuous = "densityDiag"), axisLabels = "none")
GGP9<-GGP9+theme(plot.title = element_text(color='darkorange',hjust=.3,size=42,lineheight = 1))
GGP9
#Plots individuales
p91<-getPlot(GGP9,5,1)
p92<-getPlot(GGP9,5,2)
p93<-getPlot(GGP9,5,3)
p94<-getPlot(GGP9,5,4)
p91<-p91+labs(title="Neighborhood")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p92<-p92+labs(title="Foundation")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p93<-p93+labs(title="GarageType")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p94<-p94+labs(title="MSSubClass")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p91p92p93p94
Aquí vemos dos conclusiones importantes:
Mantenemos la aparente linealidad que teníamos antes de agrupar las categorias
Es posible eliminar un cluster mas en Cimientos como se había apuntado, pero ahora se ve mejor
#Revision de cimientos . Reduccion de 5 clusters
#Columnas con valores categoricos
NFact<-which(sapply(total,is.factor))
TotalFact<-total[,NFact]
#Añado variables numericas Id y SalePrice
TotalFact$Id<-total$Id
TotalFact$SalePrice<-total$SalePrice
TrainFact<-TotalFact%>%filter(is.na(SalePrice)==FALSE)
#Cimientos 3 y 4 clusters
train.prueba<-TrainFact%>%group_by(Foundation)
train.prueba2<-train.prueba%>%summarise(media=mean(SalePrice))
rownames(train.prueba2)<-train.prueba2$Foundation
train.hcl<-hclust(dist(train.prueba2))
train.dat<-rownames(train.prueba2)
train.dat<-as.data.frame(train.dat)
train.dat[,2]<-paste0('Cimientos',cutree(train.hcl,k=3))
train.dat[,3]<-paste0('Cimientos',cutree(train.hcl,k=4))
TotalFact$FoundationMean3<-TotalFact$Foundation
TotalFact$FoundationMean4<-TotalFact$Foundation
levels(TotalFact$FoundationMean3)<- train.dat[,2]
levels(TotalFact$FoundationMean4)<- train.dat[,3]
#Carga provisional en dataset
total$Cimientos1<-TotalFact$FoundationMean3
total$Cimientos2<-TotalFact$FoundationMean4
Y aquí están los resultados para 3, 4 y 5 clusters
#Recarga de informacion
Model5<-total%>%select(Id,Cimientos1,Cimientos2,Cimientos,SalePrice)
ModelTrain5<-Model5%>%filter(is.na(SalePrice)==FALSE)%>%select(-Id)
ModelTrain5$Cimientos1<-reorder(ModelTrain5$Cimientos1,ModelTrain5$SalePrice,FUN = 'mean')
ModelTrain5$Cimientos2<-reorder(ModelTrain5$Cimientos2,ModelTrain5$SalePrice,FUN = 'mean')
ModelTrain5$Cimientos<-reorder(ModelTrain5$Cimientos,ModelTrain5$SalePrice,FUN = 'mean')
GGP10<-ggpairs(ModelTrain5, lower = list(combo='dot'), diag = list(continuous = "densityDiag"), axisLabels = "none",title='Resultados para cluster de Cimientos: 3 , 4 o 5')
GGP10<-GGP10+theme(plot.title = element_text(color='darkorange',hjust=.3,size=42,lineheight = 1))
GGP10
En detalle
p101<-getPlot(GGP10,4,1)
p102<-getPlot(GGP10,4,2)
p103<-getPlot(GGP10,4,3)
p101<-p101+labs(title="Cluster n=3")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p102<-p102+labs(title="Cluster n=4")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p103<-p103+labs(title="Cluster n=5")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p101p102p103
Graficamente la mejor opcion es n=3. Ademas vimos en la sección anterior que no había tanta diferencia
kable(Resultados.cimientos)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))%>%row_spec(1,background = 'orange')%>%row_spec(2,background = 'lawngreen')| Numero clusters | R2 Media | R2 Mediana | Diferencia_Media_Mediana |
|---|---|---|---|
| 2 | 0.0568254698693131 | 0.247754678851469 | -0.190929208982156 |
| 3 | 0.254395725745173 | 0.248262307945321 | 0.00613341779985199 |
| 4 | 0.2548092461983 | 0.252170668995711 | 0.00263857720258898 |
| 5 | 0.256199967397587 | 0.255658927697032 | 0.000541039700554968 |
| Todos | 0.256368401530415 | 0.256368401530415 | 0 |
#Se escoge 3 cluster
total$Cimientos<-total$Cimientos1
total$Cimientos1<-NULL
total$Cimientos2<-NULL
Se realiza la transformación de las categorías de las variables no numéricas en variables dummy
#Columnas con valores categoricos
NFact<-which(sapply(total,is.factor))
TotalFact1<-total[,NFact]
#Añado variables numericas Id y SalePrice
TotalFact1$Id<-total$Id
#Conversion a Dummys
Total.dummy.B<-TotalFact1%>%select(Id,B=Vecindario)
Total.dummy.C<-TotalFact1%>%select(Id,C=Cimientos)
Total.dummy.G<-TotalFact1%>%select(Id,G=UbicaGarage)
Total.dummy.N<-TotalFact1%>%select(Id,N=Clases)
modelo1.B<-as.data.frame(model.matrix(~.,Total.dummy.B))
modelo1.C<-as.data.frame(model.matrix(~.,Total.dummy.C))
modelo1.G<-as.data.frame(model.matrix(~.,Total.dummy.G))
modelo1.N<-as.data.frame(model.matrix(~.,Total.dummy.N))
modelo1.B$`(Intercept)`<-NULL
modelo1.C$`(Intercept)`<-NULL
modelo1.G$`(Intercept)`<-NULL
modelo1.N$`(Intercept)`<-NULL
modelo1<-modelo1.B
modelo1<-cbind(modelo1,modelo1.C%>%select(-Id))
modelo1<-cbind(modelo1,modelo1.G%>%select(-Id))
modelo1<-cbind(modelo1,modelo1.N%>%select(-Id))
#Modelo con dummys
Cuant<-total%>%select(Antiguedad,AntGarage,AreaPiso,BsmtQual,ExterQual,FireplaceQu,GarageFinish,GarageTotal,Habitat,KitchenQual,OverallQual,SalePrice)
modelo1.dummy<-cbind(modelo1,Cuant)
#Modelo con variables categoricas
Total.dummy<-total%>%select(Id,Vecindario,Cimientos,UbicaGarage,Clases)
modelo1.Nodummy<-cbind(Total.dummy,Cuant)
Si recordamos encontramos dos valores outliers .
El registro 524 que tenia discordancia entre los años de construcción remodelación y venta(corregido) y además tenia un precio muy bajo para el área habitable en sotano y primer piso.
Eso mismo le pasaba al registro 1299 que tenia un precio muy bajo para el área habitable y además no tenia proporción entre el área habitable, las habitaciones y los baños
En principio tenia pensado dejarles por que además en común con estos dos teniamos el registro 2550 que tenia discordancia en los años y falta de proporción entre el área habitable, las habitaciones y los baños, y este registro esta en el Test, pero he creido mas conveniente eliminarles de los datos
Antes de eliminarlos vamos a comprobar que posición ocupan en las variables numéricas normalizadas porque si son el valor extremo, máximo o minimo , al eliminarlo deberemos volver a normalizar esa variable con el nuevo extremo
#Vemos valores de variables numericas de los outliers por si hay que volver a normalizar
kable(modelo1.Nodummy%>%slice(524)%>%select(Id,Antiguedad,AntGarage,AreaPiso,GarageTotal,Habitat,OverallQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | Antiguedad | AntGarage | AreaPiso | GarageTotal | Habitat | OverallQual |
|---|---|---|---|---|---|---|
| 524 | 0 | 0 | 0.5676347 | 0.35645161 | 0.75770895 | 1 |
kable(modelo1.Nodummy%>%slice(1299)%>%select(Id,Antiguedad,AntGarage,AreaPiso,GarageTotal,Habitat,OverallQual))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id | Antiguedad | AntGarage | AreaPiso | GarageTotal | Habitat | OverallQual |
|---|---|---|---|---|---|---|
| 1299 | 0 | 0 | 1 | 0.3811828 | 0.91658963 | 1 |
Tanto Antigüedad como AntGarage ,y OverallQuall tienen varios registros con el mismo valor que el que vamos a eliminar, .
Sin embargo en AreaPiso el registro 1299 es el máximo. Cuando le eliminemos hay que normalizar de nuevo
#Eliminacion registros y normalizado AreaPiso en ambos dataset
modelo1.dummy<-modelo1.dummy%>%slice()%>%filter(Id!=524)
modelo1.dummy<-modelo1.dummy%>%slice()%>%filter(Id!=1299)
modelo1.dummy$AreaPiso<-normalize(modelo1.dummy$AreaPiso)
modelo1.Nodummy<-modelo1.Nodummy%>%slice()%>%filter(Id!=524)
modelo1.Nodummy<-modelo1.Nodummy%>%slice()%>%filter(Id!=1299)
modelo1.Nodummy$AreaPiso<-normalize(modelo1.Nodummy$AreaPiso)
modelo1.Nodummy.train<-modelo1.Nodummy%>%filter(is.na(SalePrice)==FALSE)%>%select(AreaPiso,GarageTotal,Habitat,SalePrice)
Volvemos a cargar los graficos y comparamos
Afectaban sobre todo a AreaPiso, GarageTotal y Habitat
GGP11<-ggpairs(modelo1.Nodummy.train, lower = list(continuous = my_rg1), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: Modelo Lineal (lm)-Cyan y Suavizado Local(Loess)-Rojo")
p131<-getPlot(GGP11,4,1)
p141<-getPlot(GGP11,4,2)
p151<-getPlot(GGP11,4,3)
p131<-p131+labs(title="AreaPiso")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p141<-p141+labs(title="GarageTotal")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p151<-p151+labs(title="Habitat")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p13p131p14p141p15p151
Han mejorado tanto AreaPiso como Habitat
Sin embargo tenemos otros outliers que aparecen en GarageTotal
Les seleccionamos y vemos su influencia en las dos variable anteriores (puntos en rojo)
p132<-p131+geom_point(data=modelo1.Nodummy.train,aes(x=modelo1.Nodummy.train$AreaPiso,y=modelo1.Nodummy.train$SalePrice,colour=modelo1.Nodummy.train$GarageTotal>0.5 & modelo1.Nodummy.train$SalePrice<300000))+scale_colour_manual(values = c(alpha("black",0), "red"))+theme(legend.position = 'none')
p152<-p151+geom_point(data=modelo1.Nodummy.train,aes(x=modelo1.Nodummy.train$Habitat,y=modelo1.Nodummy.train$SalePrice,colour=modelo1.Nodummy.train$GarageTotal>0.5 & modelo1.Nodummy.train$SalePrice<300000))+scale_colour_manual(values = c(alpha("black",0), "red"))+theme(legend.position = 'none')
p132p152
kable(total%>%filter(GarageTotal>0.5 & SalePrice<300000)%>%select(Id))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| Id |
|---|
| 582 |
| 1062 |
| 1191 |
| 1351 |
Los eliminamos, actualizamos, normalizamos y volvemos a revisar los graficos
#Eliminacion registros y normalizado AreaPiso en ambos dataset
modelo1.dummy<-modelo1.dummy%>%slice()%>%filter(Id!=582)
modelo1.dummy<-modelo1.dummy%>%slice()%>%filter(Id!=1062)
modelo1.dummy<-modelo1.dummy%>%slice()%>%filter(Id!=1191)
modelo1.dummy<-modelo1.dummy%>%slice()%>%filter(Id!=1351)
modelo1.dummy$AreaPiso<-normalize(modelo1.dummy$AreaPiso)
modelo1.Nodummy<-modelo1.Nodummy%>%slice()%>%filter(Id!=582)
modelo1.Nodummy<-modelo1.Nodummy%>%slice()%>%filter(Id!=1062)
modelo1.Nodummy<-modelo1.Nodummy%>%slice()%>%filter(Id!=1191)
modelo1.Nodummy<-modelo1.Nodummy%>%slice()%>%filter(Id!=1351)
modelo1.Nodummy$AreaPiso<-normalize(modelo1.Nodummy$AreaPiso)
modelo1.Nodummy.train<-modelo1.Nodummy%>%filter(is.na(SalePrice)==FALSE)%>%select(AreaPiso,GarageTotal,Habitat,SalePrice)Volvemos a cargar los graficos y comparamos
Afectaba sobre todo a GarageTotal
GGP12<-ggpairs(modelo1.Nodummy.train, lower = list(continuous = my_rg1), diag = list(continuous = "densityDiag"), axisLabels = "none",title="Regresion: Modelo Lineal (lm)-Cyan y Suavizado Local(Loess)-Rojo")
p132<-getPlot(GGP12,4,1)
p142<-getPlot(GGP12,4,2)
p152<-getPlot(GGP12,4,3)
p132<-p132+labs(title="AreaPiso")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p142<-p142+labs(title="GarageTotal")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p152<-p152+labs(title="Habitat")+theme(plot.title = element_text(color='darkorchid1',hjust=.3,size=22,lineheight = 1))
p131p132p141p142p151p152
Vamos a realizar un filtrado de las variables mediante el método sbf() del paquete caret
Vamos a realizarlo con dos funciones internas diferentes para poder comparar y validar los resultados , ramdom forest y modelo lineal
#FILTRADO DE VARIABLES CON CARET
#Filtrado con sbf de caret usando RandomForest y Linear Model
# Se crea una semilla para cada partición y cada repetición: el vector debe
# tener B+1 semillas donde B = particiones * repeticiones.
ModeloTrain.Nodummy<-modelo1.Nodummy%>%filter(is.na(SalePrice)==FALSE)%>%select(-Id)
set.seed(456)
particiones = 10
repeticiones = 5
seeds <- sample.int(1000, particiones * repeticiones + 1)
# Control del filtrado Random Forest
ctrl_filtrado.rf <- sbfControl(functions = rfSBF, method = "repeatedcv", number = particiones, repeats = repeticiones, seeds = seeds, verbose = FALSE, saveDetails = TRUE)
# Control del filtrado Linear Model
ctrl_filtrado.lm <- sbfControl(functions = lmSBF, method = "repeatedcv", number = particiones, repeats = repeticiones, seeds = seeds, verbose = FALSE, saveDetails = TRUE)
set.seed(234)
rf_sbf <- sbf(SalePrice ~ ., data = ModeloTrain.Nodummy, sbfControl = ctrl_filtrado.rf,ntree = 500)
lm_sbf <- sbf(SalePrice ~ ., data = ModeloTrain.Nodummy, sbfControl = ctrl_filtrado.lm)
#Vemos las variables que tenems quequedarnos
kable(rf_sbf$optVariables)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover")) #optimas variables segun Random Forest| x |
|---|
| VecindarioBarrio2 |
| VecindarioBarrio3 |
| VecindarioBarrio4 |
| VecindarioBarrio5 |
| CimientosCimientos2 |
| CimientosCimientos3 |
| UbicaGarageGarage2 |
| UbicaGarageGarage3 |
| UbicaGarageGarage4 |
| ClasesClase2 |
| ClasesClase3 |
| ClasesClase4 |
| ClasesClase6 |
| Antiguedad |
| AntGarage |
| AreaPiso |
| BsmtQual |
| ExterQual |
| FireplaceQu |
| GarageFinish |
| GarageTotal |
| Habitat |
| KitchenQual |
| OverallQual |
kable(lm_sbf$optVariables)%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover")) #optimas variables segun Linear Model| x |
|---|
| VecindarioBarrio2 |
| VecindarioBarrio3 |
| VecindarioBarrio4 |
| VecindarioBarrio5 |
| CimientosCimientos2 |
| CimientosCimientos3 |
| UbicaGarageGarage2 |
| UbicaGarageGarage3 |
| UbicaGarageGarage4 |
| ClasesClase2 |
| ClasesClase3 |
| ClasesClase4 |
| ClasesClase6 |
| Antiguedad |
| AntGarage |
| AreaPiso |
| BsmtQual |
| ExterQual |
| FireplaceQu |
| GarageFinish |
| GarageTotal |
| Habitat |
| KitchenQual |
| OverallQual |
Podemos apreciar que los resultados son iguales
De las 25 variables solo se ha descartado 1
Aplicamos los resultado y eliminamos variable no influyente
Modelo2.Filtrado<-modelo1.dummy%>%select(-NClase5)
Modelo2Train.Filt<-Modelo2.Filtrado%>%filter(is.na(SalePrice)==FALSE)
Antes de empezar a modelizar tenemos que eliminar la variable Id de ambos dataset, pero guardando una copia para poder enviar la respuesta
#Copia seguridad y eliminacion ID
CopiaTrain<-Modelo2Train.Filt
CopiaTest<-Modelo2.Filtrado%>%filter(is.na(SalePrice)==TRUE)
TrainFinal<-CopiaTrain%>%select(-Id)
TestFinal<-CopiaTest%>%select(-Id,-SalePrice)
Para la fijación de nuesro modelo vamos a elegir el método de la validación cruzada del dataset Train con 20 iteraciones
No sabiendo que modelo elegir, para lo cual probaremos con el método train del paquete caret diversos modelos y veremos que resultados nos aportan
Una cosa interesante que aporta este metodo es que llama a los diversos metodos de distintos paquetes con diferentes hiperparametros y se encarga de seleccionar los parametros propios de cada metodo mas eficientes
#PRUEBAS MODELOS
set.seed(234)
#MultiVariate Adaptative Regression Splines
MARS<-train(TrainFinal[,-25],TrainFinal[,25],'gcvEarth',trControl = trainControl(method = 'cv',number = 20))
#Modelo lineal
LM<-train(TrainFinal[,-25],TrainFinal[,25],'lm',trControl = trainControl(method = 'cv',number = 20))
#Ramdom Forest
RF<-train(TrainFinal[,-25],TrainFinal[,25],'ranger',trControl = trainControl(method = 'cv',number = 20))
#Modelo lineal+splines
rlm<-lm(formula = SalePrice~.,data=TrainFinal)
rnd<-lm(formula=SalePrice~bs(Antiguedad)+bs(OverallQual)+bs(BsmtQual)+bs(ExterQual)+bs(FireplaceQu)+bs(GarageFinish)+bs(KitchenQual)+AntGarage+AreaPiso+GarageTotal+Habitat+BBarrio2+BBarrio3+BBarrio4+BBarrio5+CCimientos2+CCimientos3+GGarage2+GGarage3+GGarage4+NClase2+NClase3+NClase4+NClase6 ,data=TrainFinal)
rnd2<-lm(formula=SalePrice~ns(Antiguedad)+ns(OverallQual)+ns(BsmtQual)+ns(ExterQual)+ns(FireplaceQu)+ns(GarageFinish)+ns(KitchenQual)+AntGarage+AreaPiso+GarageTotal+Habitat+BBarrio2+BBarrio3+BBarrio4+BBarrio5+CCimientos2+CCimientos3+GGarage2+GGarage3+GGarage4+NClase2+NClase3+NClase4+NClase6 ,data=TrainFinal)
#Generalized Additice Model using SPLINE
GAMS<-train(TrainFinal[,-25],TrainFinal[,25],'gamSpline',trControl = trainControl(method = 'cv',number = 20))
#Generalize Linear Models
GLM<-train(TrainFinal[,-25],TrainFinal[,25],'glm',trControl = trainControl(method = 'cv',number = 20))
#Bayesian Ridge Regression
BRR<-train(TrainFinal[,-25],TrainFinal[,25],'bridge',trControl = trainControl(method = 'cv',number = 20))
#Bayesian Ridge Regression (Model Averaged)
BLASSO<-train(TrainFinal[,-25],TrainFinal[,25],'blassoAveraged',trControl = trainControl(method = 'cv',number = 20))
#Extreme gradient boosting
XGB<-train(TrainFinal[,-25],TrainFinal[,25],'xgbLinear',trControl = trainControl(method = 'cv',number = 20))
XGBT<-train(TrainFinal[,-25],TrainFinal[,25],'xgbTree',trControl = trainControl(method = 'cv',number = 20))
Vamos a comparar los modelos elegidos
#Comprobacion resultados
options(digits=6)
model<-list(gcvEarth=MARS,lm=LM,ranger=RF,gamSpline=GAMS,glm=GLM,bridge=BRR,blassoAveraged=BLASSO,xgbLinear=XGB,xgbTree=XGBT)
result.resamples<-resamples(model)
metricas_resamples <- result.resamples$values%>%gather(key = "modelo", value = "valor", -Resample)%>%separate(col = "modelo", into = c("modelo", "metrica"), sep = "~", remove = TRUE)
#Tabla resultados
kable(metricas_resamples %>% group_by(modelo, metrica) %>% summarise(media = mean(valor)) %>% spread(key = metrica, value = media) %>% arrange(desc(Rsquared)))%>%kable_styling(full_width = F,bootstrap_options = c("striped", "hover"))| modelo | MAE | RMSE | Rsquared |
|---|---|---|---|
| xgbTree | 17900.3 | 25888.2 | 0.891002 |
| ranger | 17796.4 | 26444.9 | 0.890143 |
| gcvEarth | 18527.0 | 26813.4 | 0.882849 |
| gamSpline | 19205.6 | 27160.8 | 0.882141 |
| xgbLinear | 19324.2 | 27388.8 | 0.881359 |
| bridge | 20573.4 | 29588.9 | 0.864643 |
| blassoAveraged | 20444.0 | 29604.4 | 0.864640 |
| lm | 20440.4 | 29307.8 | 0.863801 |
| glm | 20408.2 | 29537.1 | 0.862450 |
#Calculos para ponderaciones
RS<-metricas_resamples%>%filter(metrica=="Rsquared") %>% group_by(modelo, metrica) %>% summarise(media = mean(valor)) %>% spread(key = metrica, value = media) %>% arrange(desc(Rsquared))
RSM<-metricas_resamples%>%filter(metrica=="MAE") %>% group_by(modelo, metrica) %>% summarise(media = mean(valor)) %>% spread(key = metrica, value = media) %>% arrange(desc(MAE))
RSE<-metricas_resamples%>%filter(metrica=="RMSE") %>% group_by(modelo, metrica) %>% summarise(media = mean(valor)) %>% spread(key = metrica, value = media) %>% arrange(desc(RMSE))
RST<-RS%>%spread(modelo,Rsquared)
RSMT<-RSM%>%spread(modelo,MAE)
RSET<-RSE%>%spread(modelo,RMSE)
Vemos graficamente
#Grafico
graf1<-metricas_resamples %>% filter(metrica == "Rsquared") %>% group_by(modelo) %>% summarise(media = mean(valor)) %>% ggplot(aes(x = reorder(modelo, media), y = media, label = sprintf("%0.4f",round(media, 4))))
graf1<-graf1+ geom_segment(aes(x = reorder(modelo, media), y = 0, xend = modelo, yend = media), color = "grey50")
graf1<-graf1+ geom_point(size = 10, color = "firebrick") + geom_text(color = "white", size = 2.5) + scale_y_continuous(limits = c(0.75, 1))
graf1<-graf1 + labs(title = "Rsquare con CV", subtitle = "Modelos ordenados por media", x = "modelo")
graf1<-graf1+ coord_flip() + theme_bw()
graf1
## Warning: Removed 9 rows containing missing values (geom_segment).
graf2<-bwplot(result.resamples,scales=list(relation="free"),xlim=list(c(13000,30000),c(18000,50000),c(0.7,1)))
graf2Los modelos que parecen mas efectivos son RandomForest, y xgbTree
ranger: RandomForest es un ensamble en paralelo (bagging) de arboles de predicción en los que se selecciona aleatoriamente los predictores en cada nodo
xgbTree: eXtreme Gradient Boosting es un ensamble secuencial (boosting) de arboles de predicción en el que cada árbol intenta minimizar los residuos del anterior
Los otros modelos que también dan buenos resultados son:
GAMSpline :Generalized Additive Model using Splines es una combinacion lineal de funciones no lineales.Se trata de combinar distintos tipos de regresión en un conjunto no lineal, usando aquí smooth Splines
gvcEarth: MultiVariate Adaptative Regression Splines es parecido al anterior pero usando regression splines
XGBLinear es un un ensamble secuencial como XGBoost pero orientado hacia el modelo lineal
En un data frame elijo en varias columnas las predicciones que me da cada modelo
#Calculo para distintas ponderaciones
SumaRs<-RST$ranger+RST$gamSpline+RST$xgbTree+RST$gcvEarth+RST$xgbLinear
SumaRSM<-((1/RSMT$ranger)+(1/RSMT$gamSpline)+(1/RSMT$xgbTree)+(1/RSMT$gcvEarth)+(1/RSMT$xgbLinear))
SumaRSE<-((1/RSET$ranger)+(1/RSET$gamSpline)+(1/RSET$xgbTree)+(1/RSET$gcvEarth)+(1/RSET$xgbLinear))
#Prediccion
result<-CopiaTest%>%select(-SalePrice)
result$RF<-predict(RF,TestFinal)
result$GAM<-predict(GAMS,TestFinal)
result$XGBT<-predict(XGBT,TestFinal)
result$MARS <-predict(MARS,TestFinal)
result$XGB <-predict(XGB,TestFinal)
result$media<-round(((result$RF+result$GAM+result$XGBT+result$MARS+result$XGB)/5),digits = 1)
#ponderada sobre Rsquared
result$ponderada<-round((((result$RF*RST$ranger)+(result$GAM*RST$gamSpline)+(result$XGBT*RST$xgbTree)+(result$MARS*RST$gcvEarth)+(result$XGB*RST$xgbLinear))/SumaRs),digits = 1)
#Ponderada sobre MAE
result$ponderada1<-round((((result$RF/RSMT$ranger)+(result$GAM/RSMT$gamSpline)+(result$XGBT/RSMT$xgbTree)+(result$MARS/RSMT$gcvEarth)+(result$XGB/RSMT$xgbLinear))/SumaRSM),digits = 1)
#Ponderada sobre RMSE
result$ponderada2<-round((((result$RF/RSET$ranger)+(result$GAM/RSET$gamSpline)+(result$XGBT/RSET$xgbTree)+(result$MARS/RSET$gcvEarth)+(result$XGB/RSET$xgbLinear))/SumaRSE),digits = 1)
#Redondeo hacia arriba en centenas de los valores
result$RF<-100*ceiling((result$RF/100))
result$GAM<-100*ceiling((result$GAM/100))
result$XGBT<-100*ceiling((result$XGBT/100))
result$MARS<-100*ceiling((result$MARS/100))
result$XGB<-100*ceiling((result$XGB/100))
result$media<-100*ceiling((result$media/100))
result$ponderada<-100*ceiling((result$ponderada/100))
result$ponderada1<-100*ceiling((result$ponderada1/100))
result$ponderada2<-100*ceiling((result$ponderada2/100))Fin<-result%>%select(Id,SalePrice=media)
Fin1<-result%>%select(Id,SalePrice=RF)
Fin2<-result%>%select(Id,SalePrice=GAM)
Fin3<-result%>%select(Id,SalePrice=XGBT)
Fin4<-result%>%select(Id,SalePrice=MARS)
Fin5<-result%>%select(Id,SalePrice=XGB)
Fin6<-result%>%select(Id,SalePrice=ponderada)
Fin7<-result%>%select(Id,SalePrice=ponderada1)
Fin8<-result%>%select(Id,SalePrice=ponderada2)
write.csv(Fin,file="Ames2_house.csv",row.names = FALSE)
write.csv(Fin1,file="Ames2_house1.csv",row.names = FALSE)
write.csv(Fin2,file="Ames2_house2.csv",row.names = FALSE)
write.csv(Fin3,file="Ames2_house3.csv",row.names = FALSE)
write.csv(Fin4,file="Ames2_house4.csv",row.names = FALSE)
write.csv(Fin5,file="Ames2_house5.csv",row.names = FALSE)
write.csv(Fin6,file="Ames2_house6.csv",row.names = FALSE)
write.csv(Fin7,file="Ames2_house7.csv",row.names = FALSE)
write.csv(Fin8,file="Ames2_house8.csv",row.names = FALSE)Estos son los resultado en Kaggle.
El valor corresponde al resultado aplicado al TEST que nos da RMSLE: Root Mean Squared Logarithmic Error similar al RMSE pero aplicando una reduccion logaritmica previa a los datos
include_graphics('Kaggle1.bmp')Podemos apreciar que los valores son muy parecidos tanto en la media directa de los modelos escogidos como en aquella ponderacion con el criterio que sea
include_graphics('Kaggle2.bmp')Aunque se mantiene el orden de eficiencia que habiamos obtenido de los modelos durante el entrenamiento , hay que destacar que cualquier mezcla de varios sea con el criterio que sea de ponderacion es mejor que el mejor de los modelos en solitario